Issue238.hs

{-# LANGUAGE OverloadedStrings #-}

-- | Tests for <https://github.com/well-typed/grapesy/issues/238>
module Test.Regression.Issue238 (tests) where

import Control.Exception
import Data.ByteString.Lazy (ByteString)
import Data.Text qualified as Text
import Test.Tasty
import Test.Tasty.HUnit

import Network.GRPC.Client (rpc)
import Network.GRPC.Client qualified as Client
import Network.GRPC.Client.StreamType.IO qualified as Client
import Network.GRPC.Common
import Network.GRPC.Common.Protobuf
import Network.GRPC.Server qualified as Server
import Network.GRPC.Server.Protobuf qualified as Server
import Network.GRPC.Server.Run qualified as Server
import Network.GRPC.Server.StreamType qualified as Server

import Proto.API.RouteGuide
import Proto.API.Trivial

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

tests :: TestTree
tests = testGroup "Issue238" [
      testGroup "Trivial" [
          testCase "nonStreaming1" test_trivial_nonStreaming1
        , testCase "nonStreaming2" test_trivial_nonStreaming2
        ]
    , testGroup "LowLevel" [
          testCase "nonStreaming1" test_lowLevel_nonStreaming1
        , testCase "nonStreaming2" test_lowLevel_nonStreaming2
        ]
    , testGroup "RouteGuide" [
          testCase "nonStreaming1" test_routeGuide_nonStreaming1
        , testCase "nonStreaming2" test_routeGuide_nonStreaming2
        , testCase "nonStreaming3" test_routeGuide_nonStreaming3
        ]
    ]

{-------------------------------------------------------------------------------
  Without Protobuf
-------------------------------------------------------------------------------}

-- | Undefined handler body
test_trivial_nonStreaming1 :: Assertion
test_trivial_nonStreaming1 =
    testWith handlers client
  where
    handlers :: [Server.SomeRpcHandler IO]
    handlers = [Server.someRpcHandler $ Server.mkRpcHandler @Trivial undefined]

    client :: Client.Connection -> IO ByteString
    client conn = Client.nonStreaming conn (rpc @Trivial) mempty

-- | Like 'test_trivial_nonStreaming1', but without the call to @mkRpcHandler@
--
-- This matters, because 'mkRpcHandler' sets the initial metadata.
test_trivial_nonStreaming2 :: Assertion
test_trivial_nonStreaming2 =
    testWith handlers client
  where
    handlers :: [Server.SomeRpcHandler IO]
    handlers = [Server.someRpcHandler @Trivial undefined]

    client :: Client.Connection -> IO ByteString
    client conn = Client.nonStreaming conn (rpc @Trivial) mempty

{-------------------------------------------------------------------------------
  Low-level API

  The ticket specifically says "when client uses high-level API". In this
  section we therefore compare the behaviour of the @test_trivial@ tests (which
  use the high-level API) to the corresponding behaviour with the low-level API.
-------------------------------------------------------------------------------}

-- | Direct equivalent of 'test_trivial_nonStreaming2'
test_lowLevel_nonStreaming1 :: Assertion
test_lowLevel_nonStreaming1 =
    testWith handlers client
  where
    handlers :: [Server.SomeRpcHandler IO]
    handlers = [Server.someRpcHandler @Trivial undefined]

    client :: Client.Connection -> IO ByteString
    client conn =
        Client.withRPC conn def (Proxy @Trivial) $ \call -> do
          Client.sendFinalInput call mempty
          fst <$> Client.recvFinalOutput call

-- | Like 'test_lowLevel_nonStreaming1, but without sending the input
test_lowLevel_nonStreaming2 :: Assertion
test_lowLevel_nonStreaming2 =
    testWith handlers client
  where
    handlers :: [Server.SomeRpcHandler IO]
    handlers = [Server.someRpcHandler @Trivial undefined]

    client :: Client.Connection -> IO ByteString
    client conn =
        Client.withRPC conn def (Proxy @Trivial) $ \call -> do
          fst <$> Client.recvFinalOutput call

{-------------------------------------------------------------------------------
  With Protobuf

  Crucially, this uses 'fromMethods', which is not unlikely to have undefineds
  in it during development.

  The @test_routeGuide_nonStreaming<N>@ tests all use @undefined@ somewhere in
  the declaration of the methods, but differ on how much is defined.
-------------------------------------------------------------------------------}

-- | Completely @undefined@ 'Methods'
--
-- This is different from 'test_routeGuide_nonStreaming2', where the /skeleton/
-- is defined but the individual handlers are not: here we cannot even construct
-- the list without triggering an exception, forcing us to be very careful with
-- exception handling during lookup.
test_routeGuide_nonStreaming1 :: Assertion
test_routeGuide_nonStreaming1 =
    testWith (Server.fromMethods methods) client
  where
    methods :: Server.Methods IO (Server.ProtobufMethodsOf RouteGuide)
    methods = undefined

    client :: Client.Connection -> IO (Proto Feature)
    client conn = Client.nonStreaming conn (rpc @GetFeature) defMessage

test_routeGuide_nonStreaming2 :: Assertion
test_routeGuide_nonStreaming2 =
    testWith (Server.fromMethods methods) client
  where
    methods :: Server.Methods IO (Server.ProtobufMethodsOf RouteGuide)
    methods =
          Server.Method undefined
        $ Server.Method undefined
        $ Server.Method undefined
        $ Server.Method undefined
        $ Server.NoMoreMethods

    client :: Client.Connection -> IO (Proto Feature)
    client conn = Client.nonStreaming conn (rpc @GetFeature) defMessage

test_routeGuide_nonStreaming3 :: Assertion
test_routeGuide_nonStreaming3 =
    testWith (Server.fromMethods methods) client
  where
    methods :: Server.Methods IO (Server.ProtobufMethodsOf RouteGuide)
    methods =
          Server.Method (Server.mkNonStreaming undefined)
        $ Server.Method undefined
        $ Server.Method undefined
        $ Server.Method undefined
        $ Server.NoMoreMethods

    client :: Client.Connection -> IO (Proto Feature)
    client conn = Client.nonStreaming conn (rpc @GetFeature) defMessage

{-------------------------------------------------------------------------------
  Auxiliary: test setup

  We don't use the test clients/server infrastructure here, since this issue
  is about exception handling, and the test harnass does quite a bit of
  exception processing.
-------------------------------------------------------------------------------}

testWith ::
     [Server.SomeRpcHandler IO]
  -> (Client.Connection -> IO a)
  -> Assertion
testWith handlers client = do
    server <- Server.mkGrpcServer serverParams handlers
    Server.forkServer def serverConfig server $ \runningServer -> do
      serverPort <- Server.getServerPort runningServer

      let serverAddr = Client.ServerInsecure $ Client.Address {
           addressHost      = "127.0.0.1"
         , addressPort      = serverPort
         , addressAuthority = Nothing
         }
      Client.withConnection def serverAddr $ \conn ->
        checkClientReceivesUndefined $ client conn
  where
    serverConfig :: Server.ServerConfig
    serverConfig = Server.ServerConfig {
          serverInsecure = Just $ Server.InsecureConfig (Just "127.0.0.1") 0
        , serverSecure   = Nothing
        }

    serverParams :: Server.ServerParams
    serverParams = def {
          Server.serverTopLevel = \handler unmask req resp -> do
            _result :: Either SomeException () <- try $ handler unmask req resp
            -- Ignore any exceptions
            return ()
        }

-- | Verify that the client  is notified of the undefined handler
checkClientReceivesUndefined ::
     HasCallStack
  => IO a -> Assertion
checkClientReceivesUndefined k = do
    result <- try k
    case result of
      Right _ ->
        assertFailure "Unexpected successful response"
      Left err ->
        case grpcErrorMessage err of
          Just msg ->
            assertBool (show (Text.unpack msg) ++ " contains \"undefined\"") $
              "undefined" `Text.isInfixOf` msg
          Nothing ->
            assertFailure "Missing error message"