Interop.hs

{-# LANGUAGE OverloadedLabels  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Test functionality required by the gRPC interop tests
module Test.Sanity.Interop (tests) where

import Control.Concurrent (threadDelay)
import Control.Exception
import Control.Monad
import Data.ByteString qualified as BS.Strict
import Data.Proxy
import Test.Tasty
import Test.Tasty.HUnit

import Network.GRPC.Client qualified as Client
import Network.GRPC.Client.Binary qualified as Client.Binary
import Network.GRPC.Client.StreamType.IO qualified as Client
import Network.GRPC.Common
import Network.GRPC.Common.Binary (RawRpc)
import Network.GRPC.Common.Protobuf
import Network.GRPC.Common.StreamElem qualified as StreamElem
import Network.GRPC.Server qualified as Server
import Network.GRPC.Server.Binary qualified as Server.Binary
import Network.GRPC.Server.StreamType (ServerHandler'(..))
import Network.GRPC.Server.StreamType qualified as Server

import Proto.API.Interop
import Proto.API.Ping

import Test.Driver.ClientServer

{-------------------------------------------------------------------------------
  Top-level
-------------------------------------------------------------------------------}

tests :: TestTree
tests = testGroup "Test.Sanity.Interop" [
      testGroup "preliminary" [
          testCase "callAfterException" test_callAfterException
        ]
    , testGroup "cancellation" [
          testCase "client" test_cancellation_client
        , testCase "server" test_cancellation_server
        ]
    , testGroup "official" [
          testCase "emptyUnary"                test_emptyUnary
        , testCase "serverCompressedStreaming" test_serverCompressedStreaming
        ]
    ]

{-------------------------------------------------------------------------------
  Preliminary: verify that we can do a second call on the same connection,
  even if the first failed with a gRPC exception
-------------------------------------------------------------------------------}

test_callAfterException :: IO ()
test_callAfterException =
    testClientServer $ ClientServerTest {
        config = def
      , client = simpleTestClient $ \conn -> do
          resp1 <- ping conn $ defMessage & #id .~ 0
          case resp1 of
            Left _  -> return ()
            Right _ -> assertFailure "Expected gRPC exception"

          resp2 <- ping conn $ defMessage & #id .~ 1
          case resp2 of
            Left  _ -> assertFailure "Expected pong"
            Right i -> assertEqual "pong" i (defMessage & #id .~ 1)
      , server = [
            Server.someRpcHandler $
              Server.mkRpcHandler @Ping $ \call -> do
                pingMsg <- Server.recvFinalInput call
                if pingMsg ^. #id > 0 then do
                  let pongMsg :: Proto PongMessage
                      pongMsg = defMessage & #id .~ (pingMsg ^. #id)
                  Server.sendFinalOutput call (pongMsg, NoMetadata)
                else
                  Server.sendGrpcException call $ GrpcException {
                      grpcError         = GrpcInvalidArgument
                    , grpcErrorMessage  = Just "Expected non-zero ping"
                    , grpcErrorDetails  = Nothing
                    , grpcErrorMetadata = []
                    }
          ]
      }
  where
    ping ::
         Client.Connection
      -> Proto PingMessage
      -> IO (Either SomeException (Proto PongMessage))
    ping conn = try . Client.nonStreaming conn (Client.rpc @Ping)

{-------------------------------------------------------------------------------
  @empty_unary@

  <https://github.com/grpc/grpc/blob/master/doc/interop-test-descriptions.md#empty_unary>
-------------------------------------------------------------------------------}

-- | Test that the empty message has an empty encoding
--
-- This test fails if we unconditionally compress (the /compressed/ form of the
-- empty message is larger than the uncompressed form, as compression introduces
-- minor overhead).
test_emptyUnary :: IO ()
test_emptyUnary =
    testClientServer $ ClientServerTest {
        config = def
      , client = simpleTestClient $ \conn ->
          Client.withRPC conn def (Proxy @EmptyCall) $ \call -> do
            Client.sendFinalInput call defMessage
            streamElem <- Client.recvOutputWithMeta call
            case StreamElem.value streamElem of
              Nothing         -> fail "Expected answer"
              Just (meta, _x) -> verifyMeta meta
      , server = [
            Server.fromMethod @EmptyCall $ ServerHandler $ \_empty ->
              return defMessage
          ]
      }
  where
    -- We don't /expect/ the empty message to be compressed, due to the overhead
    -- mentioned above. However, /if/ it is compressed, perhaps using a custom
    -- zero-overhead compression algorithm, it's size should be zero.
    verifyMeta :: InboundMeta -> IO ()
    verifyMeta meta = do
        assertEqual "uncompressed size" (inboundUncompressedSize meta) 0
        case inboundCompressedSize meta of
          Nothing   -> return ()
          Just size -> assertEqual "compressed size" size 0

{-------------------------------------------------------------------------------
  @server_compressed_streaming@

  <https://github.com/grpc/grpc/blob/master/doc/interop-test-descriptions.md#server_compressed_streaming>
-------------------------------------------------------------------------------}

-- | Test that we can enable and disable compression per message
test_serverCompressedStreaming :: IO ()
test_serverCompressedStreaming =
    testClientServer ClientServerTest {
        config = def
      , client = simpleTestClient $ \conn ->
          Client.withRPC conn def (Proxy @StreamingOutputCall) $ \call -> do
            Client.sendFinalInput call $ defMessage & #responseParameters .~ [
                defMessage
                  & #compressed .~ (defMessage & #value .~ True)
                  & #size .~ 31415
              , defMessage
                  & #compressed .~ (defMessage & #value .~ False)
                  & #size .~ 92653
              ]
            output1 <- Client.recvOutputWithMeta call
            output2 <- Client.recvOutputWithMeta call
            verifyOutputs (StreamElem.value output1, StreamElem.value output2)
      , server = [
            Server.someRpcHandler $
              Server.mkRpcHandler @StreamingOutputCall $ \call -> do
                handleStreamingOutputCall call
          ]
      }
  where
    handleStreamingOutputCall :: Server.Call StreamingOutputCall -> IO ()
    handleStreamingOutputCall call = do
        -- Wait for request
        request <- Server.recvFinalInput call

        -- Send all requested messages
        forM_ (request ^. #responseParameters) $ \responseParams -> do

          let shouldCompress :: Bool
              shouldCompress = responseParams ^. #compressed . #value

              size :: Int
              size = fromIntegral $ responseParams ^. #size

              meta :: OutboundMeta
              meta = def { outboundEnableCompression = shouldCompress }

              -- Payload matters for the test, because for messages that are too
              -- small no compression is used even when enabled.
              payload :: Proto Payload
              payload = defMessage & #body .~ BS.Strict.pack (replicate size 0)

              response :: Proto StreamingOutputCallResponse
              response = defMessage & #payload .~ payload

          Server.sendOutputWithMeta call $ StreamElem (meta, response)

        -- No further output
        Server.sendTrailers call def

    verifyOutputs ::
         ( Maybe (InboundMeta, Proto StreamingOutputCallResponse)
         , Maybe (InboundMeta, Proto StreamingOutputCallResponse)
         )
      -> IO ()
    verifyOutputs = \case
        (Just (meta1, _), Just (meta2, _)) -> do
          case inboundCompressedSize meta1 of
            Nothing -> assertFailure "First output should be compressed"
            Just _  -> return ()
          case inboundCompressedSize meta2 of
            Nothing -> return ()
            Just _  -> assertFailure "First output should not be compressed"
        _otherwise ->
          assertFailure "Expected value"

{-------------------------------------------------------------------------------
  Cancellation
-------------------------------------------------------------------------------}

type StreamNats = RawRpc "test" "nats"

test_cancellation_client :: IO ()
test_cancellation_client =
    testClientServer ClientServerTest {
        config = def {
            isExpectedServerException = isClientDisconnected
          }
      , client = simpleTestClient $ \conn -> do
          -- We wait for the first input, but then cancel the request
          result :: Either GrpcException (Maybe Int) <- try $
            Client.withRPC conn def (Proxy @StreamNats) $ \call -> do
              StreamElem.value <$> Client.Binary.recvOutput call

          -- Since we did not tell the server that we have sent our final
          -- outbound message, the client should receive a CANCELLED exception.
          case result of
            Left err ->
              assertEqual "grpcError" GrpcCancelled $ grpcError err
            Right _ ->
              assertFailure "Expected exception"
      , server = [
          Server.someRpcHandler $
            Server.mkRpcHandler @StreamNats $ \call -> do
              forM_ [1 .. 100] $ \(i :: Int) -> do
                Server.Binary.sendNextOutput call i
                threadDelay 100_000
              Server.sendTrailers call NoMetadata
        ]
      }

test_cancellation_server :: IO ()
test_cancellation_server =
    testClientServer ClientServerTest {
        config = def {
            isExpectedServerException = isHandlerTerminated
          }
      , client = simpleTestClient $ \conn -> do
          result :: Either GrpcException [Int] <- try $
            Client.withRPC conn def (Proxy @StreamNats) $ \call -> do
              Client.sendEndOfInput call
              let loop :: [Int] -> IO [Int]
                  loop acc = do
                      mx <- StreamElem.value <$> Client.Binary.recvOutput call
                      case mx of
                        Nothing -> return $ reverse acc
                        Just x  -> loop (x:acc)
              loop []
          case result of
            Left err -> do
              assertEqual "grpcError" GrpcUnknown $
                grpcError err
              assertEqual "grpcErrorMessage" (Just "Server-side exception: HandlerTerminated") $
                grpcErrorMessage err
            Right _ ->
              assertFailure "Expected exception"
      , server = [
          Server.someRpcHandler $
            -- The server sends only one value, then gives up
            Server.mkRpcHandler @StreamNats $ \call -> do
              Server.Binary.sendNextOutput call (1 :: Int)
        ]
      }

{-------------------------------------------------------------------------------
  Internal: we don't care about metadata in these tests
-------------------------------------------------------------------------------}

type instance RequestMetadata          (RawRpc "test" meth) = NoMetadata
type instance ResponseInitialMetadata  (RawRpc "test" meth) = NoMetadata
type instance ResponseTrailingMetadata (RawRpc "test" meth) = NoMetadata