diff --git a/grapesy/test-grapesy/Test/Driver/ClientServer.hs b/grapesy/test-grapesy/Test/Driver/ClientServer.hs index 7959ac0e..abc3732b 100644 --- a/grapesy/test-grapesy/Test/Driver/ClientServer.hs +++ b/grapesy/test-grapesy/Test/Driver/ClientServer.hs @@ -11,11 +11,21 @@ module Test.Driver.ClientServer ( , TlsSetup(..) , TlsFail(..) , TlsOk(..) + -- ** Expected exceptions + , DeliberateException(..) + , isDeliberateException + , isClientDisconnected + , isInvalidRequestHeaders + , isGrpc415 + , isGrpc400 + , isGrpcCancelled + , isHandshakeFailed + , isServerUnsupportedCompression + , isClientUnsupportedCompression + , isHandlerTerminated -- * Constructing clients , TestClient , simpleTestClient - -- * Exception handling - , DeliberateException(..) ) where import Control.Concurrent @@ -25,9 +35,6 @@ import Control.Exception (throwIO) import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class -import Data.Map qualified as Map -import Data.Set (Set) -import Data.Set qualified as Set import Data.Text qualified as Text import Network.HTTP2.Server qualified as HTTP2.Server import Network.Socket (PortNumber) @@ -88,17 +95,11 @@ data ClientServerConfig = ClientServerConfig { -- | Override content-type used by the server , serverContentType :: ContentTypeOverride - -- | Should we expect any clients to terminate early? - -- - -- \"Termination\" here could be either normal termination (no exception, - -- but not properly closing the RPC call either) or abnormal termination - -- (throwing an exception). - , expectEarlyClientTermination :: Bool + -- | Is this exception expected on the client? + , isExpectedClientException :: SomeException -> Bool - -- | Should we expect any server handlers to terminate early? - -- - -- Same comments for \"termination\" apply. - , expectEarlyServerTermination :: Bool + -- | Is this exception expected on the server? + , isExpectedServerException :: SomeException -> Bool } data ContentTypeOverride = @@ -116,15 +117,15 @@ data ContentTypeOverride = instance Default ClientServerConfig where def = ClientServerConfig { - serverPort = 0 - , clientCompr = def - , clientInitCompr = Nothing - , serverCompr = def - , useTLS = Nothing - , clientContentType = NoOverride - , serverContentType = NoOverride - , expectEarlyClientTermination = False - , expectEarlyServerTermination = False + serverPort = 0 + , clientCompr = def + , clientInitCompr = Nothing + , serverCompr = def + , useTLS = Nothing + , clientContentType = NoOverride + , serverContentType = NoOverride + , isExpectedClientException = const False + , isExpectedServerException = const False } {------------------------------------------------------------------------------- @@ -169,150 +170,74 @@ data TlsFail = we don't see these exceptions server-side. -------------------------------------------------------------------------------} -isExpectedServerException :: ClientServerConfig -> SomeException -> Bool -isExpectedServerException cfg e - -- - -- Deliberate exceptions - -- - - | Just (DeliberateException _) <- fromException e - = True - - -- - -- Early client termination - -- - - | Just Server.ClientDisconnected{} <- fromException e - , expectEarlyClientTermination cfg - = True - - -- - -- Early server termination - -- - - | Just Server.HandlerTerminated{} <- fromException e - , expectEarlyServerTermination cfg - = True - - -- - -- Call setup failure - -- - - | Just Server.CallSetupInvalidRequestHeaders{} <- fromException e - , InvalidOverride _ <- clientContentType cfg - = True - - -- - -- Compression negotation - -- - - | Just Server.CallSetupUnsupportedCompression{} <- fromException e - , compressionNegotationFailure cfg - = True - - -- - -- Fall-through - -- - - | otherwise - = False - -isExpectedClientException :: ClientServerConfig -> SomeException -> Bool -isExpectedClientException cfg e - -- - -- Deliberate exceptions - -- - - -- Client threw deliberate exception - | Just (DeliberateException _) <- fromException e - = True - - -- Server threw deliberate exception - | Just grpcException <- fromException e - , Just msg <- grpcErrorMessage grpcException - , "DeliberateException" `Text.isInfixOf` msg - = True - - -- - -- Early client termination - -- - - | Just grpcException <- fromException e - , expectEarlyClientTermination cfg - , grpcError grpcException == GrpcCancelled - = True - - -- - -- Early server termination - -- - - | Just grpcException <- fromException e - , Just msg <- grpcErrorMessage grpcException - , "HandlerTerminated" `Text.isInfixOf` msg - , expectEarlyServerTermination cfg - = True - - -- - -- Call setup failure - -- - - | Just grpcException <- fromException e - , GrpcUnknown <- grpcError grpcException - , Just msg <- grpcErrorMessage grpcException - , "415" `Text.isInfixOf` msg - , InvalidOverride _ <- clientContentType cfg - = True - - -- - -- Compression negotation - -- - - -- Client choose unsupported compression - -- - -- We respond with 400 Bad Request, which gets turned into GrpcInternal - -- by 'classifyServerResponse'. - | Just grpcException <- fromException e - , GrpcInternal <- grpcError grpcException - , compressionNegotationFailure cfg - = True - - -- Server chose unsupported compression - | Just Client.CallSetupUnsupportedCompression{} <- fromException e - , compressionNegotationFailure cfg - = True - - -- - -- TLS problems - -- - - | Just tls <- fromException e - , isExpectedTLSException cfg tls - = True - - -- - -- Fall-through - -- - - | otherwise - = False - -compressionNegotationFailure :: ClientServerConfig -> Bool -compressionNegotationFailure cfg = or [ - Set.disjoint clientSupported serverSupported - , case clientInitCompr cfg of - Nothing -> False - Just compr -> Compr.compressionId compr `Set.notMember` serverSupported - ] - where - clientSupported, serverSupported :: Set Compr.CompressionId - clientSupported = Map.keysSet (Compr.supported (clientCompr cfg)) - serverSupported = Map.keysSet (Compr.supported (serverCompr cfg)) - -isExpectedTLSException :: ClientServerConfig -> TLSException -> Bool -isExpectedTLSException cfg tls = - case (useTLS cfg, tls) of - (Just (TlsFail TlsFailValidation) , HandshakeFailed _) -> True - (Just (TlsFail TlsFailUnsupported) , HandshakeFailed _) -> True +isDeliberateException :: SomeException -> Bool +isDeliberateException e = + case fromException e of + Just DeliberateException{} -> True + _otherwise -> False + +isClientDisconnected :: SomeException -> Bool +isClientDisconnected e = + case fromException e of + Just Server.ClientDisconnected{} -> True + _otherwise -> False + +isInvalidRequestHeaders :: SomeException -> Bool +isInvalidRequestHeaders e = + case fromException e of + Just Server.CallSetupInvalidRequestHeaders{} -> True + _otherwise -> False + +isGrpc415 :: SomeException -> Bool +isGrpc415 e = + case fromException e of + Just err' | Just msg <- grpcErrorMessage err' -> and [ + grpcError err' == GrpcUnknown + , "415" `Text.isInfixOf` msg + ] + _otherwise -> False + +-- | Client choose unsupported compression +-- +-- We respond with 400 Bad Request, which gets turned into GrpcInternal +-- by 'classifyServerResponse'. +isGrpc400 :: SomeException -> Bool +isGrpc400 e = + case fromException e of + Just err' | Just msg <- grpcErrorMessage err' -> and [ + grpcError err' == GrpcInternal + , "400" `Text.isInfixOf` msg + ] + _otherwise -> False + +isGrpcCancelled :: SomeException -> Bool +isGrpcCancelled e = + case fromException e of + Just err' -> grpcError err' == GrpcCancelled + _otherwise -> False + +isHandshakeFailed :: SomeException -> Bool +isHandshakeFailed e = + case fromException e of + Just HandshakeFailed{} -> True + _otherwise -> False + +isServerUnsupportedCompression :: SomeException -> Bool +isServerUnsupportedCompression e = + case fromException e of + Just Server.CallSetupUnsupportedCompression{} -> True + _otherwise -> False + +isClientUnsupportedCompression :: SomeException -> Bool +isClientUnsupportedCompression e = + case fromException e of + Just Client.CallSetupUnsupportedCompression{} -> True + _otherwise -> False + +isHandlerTerminated :: SomeException -> Bool +isHandlerTerminated e = + case fromException e of + Just Server.HandlerTerminated{} -> True _otherwise -> False {------------------------------------------------------------------------------- @@ -353,7 +278,11 @@ isExpectedTLSException cfg tls = -- as \"the\" test failure is not very important; by definition, in this case -- the one exception cannot be the /cause/ for the other exception (if it was, -- then one must happen /before/ the other). -newtype FirstTestFailure = FirstTestFailure (TMVar SomeException) +data FirstTestFailure = + FirstFailureInClient SomeException + | FirstFailureInServer SomeException + deriving stock (Show) + deriving anyclass (Exception) data TestFailure = TestFailure deriving stock (Show) @@ -362,8 +291,8 @@ data TestFailure = TestFailure -- | Mark test failure -- -- Does nothing if an earlier test failure has already been marked. -markTestFailure :: FirstTestFailure -> SomeException -> IO () -markTestFailure (FirstTestFailure firstTestFailure) err = +markTestFailure :: TMVar FirstTestFailure -> FirstTestFailure -> IO () +markTestFailure firstTestFailure err = void $ atomically $ tryPutTMVar firstTestFailure err {------------------------------------------------------------------------------- @@ -389,7 +318,7 @@ waitForHandlerTermination (ServerHandlerLock lock) = do topLevelWithHandlerLock :: ClientServerConfig - -> FirstTestFailure + -> TMVar FirstTestFailure -> ServerHandlerLock -> Server.RequestHandler () -> Server.RequestHandler () @@ -413,7 +342,7 @@ topLevelWithHandlerLock cfg Left err | isExpectedServerException cfg err -> return () Left err -> - markTestFailure firstTestFailure err + markTestFailure firstTestFailure (FirstFailureInServer err) markDone markActive, markDone :: IO () @@ -426,7 +355,7 @@ topLevelWithHandlerLock cfg withTestServer :: ClientServerConfig - -> FirstTestFailure + -> TMVar FirstTestFailure -> ServerHandlerLock -> [Server.SomeRpcHandler IO] -> (Server.RunningServer -> IO a) @@ -507,7 +436,7 @@ simpleTestClient test params testServer delimitTestScope = runTestClient :: ClientServerConfig - -> FirstTestFailure + -> TMVar FirstTestFailure -> PortNumber -> TestClient -> IO () @@ -592,7 +521,7 @@ runTestClient cfg firstTestFailure port clientRun = do Left err | isExpectedClientException cfg err -> return () Left err -> do - markTestFailure firstTestFailure err + markTestFailure firstTestFailure (FirstFailureInClient err) throwIO TestFailure clientRun clientParams clientServer delimitTestScope @@ -610,7 +539,7 @@ data ClientServerTest = ClientServerTest { runTestClientServer :: ClientServerTest -> IO () runTestClientServer (ClientServerTest cfg clientRun handlers) = do -- Setup client and server - firstTestFailure <- FirstTestFailure <$> newEmptyTMVarIO + firstTestFailure <- newEmptyTMVarIO serverHandlerLock <- newServerHandlerLock let server :: (Server.RunningServer -> IO a) -> IO a @@ -653,11 +582,11 @@ runTestClientServer (ClientServerTest cfg clientRun handlers) = do -- happen if the server fails to start at all, or if there is a bug in the test -- framework itself. waitForFailure :: - Server.RunningServer -- ^ Server - -> Async () -- ^ Client - -> FirstTestFailure -- ^ First test failure - -> STM SomeException -waitForFailure server client (FirstTestFailure firstTestFailure) = + Server.RunningServer -- ^ Server + -> Async () -- ^ Client + -> TMVar FirstTestFailure -- ^ First test failure + -> STM FirstTestFailure +waitForFailure server client firstTestFailure = (readTMVar firstTestFailure) `orElse` (Server.waitServerSTM server >>= serverAux) @@ -668,13 +597,13 @@ waitForFailure server client (FirstTestFailure firstTestFailure) = ( Either SomeException () , Either SomeException () ) - -> STM SomeException - serverAux (Left e, _) = return e - serverAux (_, Left e) = return e + -> STM FirstTestFailure + serverAux (Left e, _) = return (FirstFailureInServer e) + serverAux (_, Left e) = return (FirstFailureInServer e) serverAux _otherwise = throwSTM $ UnexpectedServerTermination - clientAux :: Either SomeException () -> STM SomeException - clientAux (Left e) = return e + clientAux :: Either SomeException () -> STM FirstTestFailure + clientAux (Left e) = return (FirstFailureInClient e) clientAux _otherwise = retry -- | We don't expect the server to shutdown until we kill it diff --git a/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs b/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs index 9647dd20..85371e75 100644 --- a/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs +++ b/grapesy/test-grapesy/Test/Driver/Dialogue/Execution.hs @@ -413,7 +413,7 @@ serverLocal clock call = \(LocalSteps steps) -> do Terminate mErr -> do mInp <- liftIO $ try $ within timeoutReceive action $ Server.Binary.recvInput call - expect (tick, action) isClientDisconnected mInp + expect (tick, action) isExpectedDisconnect mInp modify $ ifPeerAlive $ PeerTerminated $ DeliberateException <$> mErr -- Wait for the client disconnect to become visible @@ -446,15 +446,15 @@ serverLocal clock call = \(LocalSteps steps) -> do isExpectedElem _ (Left _) = False isExpectedElem expectedElem (Right streamElem) = expectedElem == streamElem - isClientDisconnected :: + isExpectedDisconnect :: Either Server.ClientDisconnected (StreamElem NoMetadata Int) -> Bool - isClientDisconnected (Left (Server.ClientDisconnected e _)) + isExpectedDisconnect (Left (Server.ClientDisconnected e _)) | Just HTTP2.Client.ConnectionIsClosed <- fromException e = True | otherwise = False - isClientDisconnected _ = False + isExpectedDisconnect _ = False serverGlobal :: HasCallStack @@ -511,8 +511,14 @@ execGlobalSteps connUsage steps = do return ClientServerTest { config = def { - expectEarlyClientTermination = clientTerminatesEarly - , expectEarlyServerTermination = serverTerminatesEarly + isExpectedClientException = \e -> or [ + isDeliberateException e + , clientTerminatesEarly && isGrpcCancelled e + ] + , isExpectedServerException = \e -> or [ + isDeliberateException e + , serverTerminatesEarly && isHandlerTerminated e + ] } , client = clientGlobal clock connUsage steps , server = [ diff --git a/grapesy/test-grapesy/Test/Regression/Issue102.hs b/grapesy/test-grapesy/Test/Regression/Issue102.hs index f88228b9..92a5d412 100644 --- a/grapesy/test-grapesy/Test/Regression/Issue102.hs +++ b/grapesy/test-grapesy/Test/Regression/Issue102.hs @@ -48,7 +48,10 @@ tests = testGroup "Issue102" [ -- | Client makes many concurrent calls, throws an exception during one of them. test_clientException :: IO () test_clientException = testClientServer $ ClientServerTest { - config = def { expectEarlyClientTermination = True } + config = def { + isExpectedClientException = isDeliberateException + , isExpectedServerException = isClientDisconnected + } , client = simpleTestClient $ \conn -> do -- Make 100 concurrent calls. 99 of them counting to 50, and one -- more that throws an exception once it reaches 10. @@ -90,7 +93,7 @@ test_serverException :: IO () test_serverException = do handlerCounter <- newIORef @Int 0 testClientServer $ ClientServerTest { - config = def { expectEarlyServerTermination = True } + config = def { isExpectedServerException = isDeliberateException } , client = simpleTestClient $ \conn -> do -- Make 100 concurrent calls counting to 50. let predicate = (> 50) @@ -131,7 +134,10 @@ test_serverException = do -- does not wait for client termination. test_earlyTerminationNoWait :: IO () test_earlyTerminationNoWait = testClientServer $ ClientServerTest { - config = def { expectEarlyClientTermination = True } + config = def { + isExpectedClientException = isDeliberateException + , isExpectedServerException = isClientDisconnected + } , client = simpleTestClient $ \conn -> do _mResult <- try @DeliberateException $ diff --git a/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs b/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs index f7f8cdcb..0dae69c5 100644 --- a/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs +++ b/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs @@ -348,7 +348,9 @@ test_undefinedOutput :: Assertion test_undefinedOutput = do st <- newIORef 0 testClientServer $ ClientServerTest { - config = def + config = def { + isExpectedServerException = isDeliberateException + } , server = [Server.fromMethod @Ping $ Server.mkNonStreaming (handler st)] , client = simpleTestClient $ \conn -> do @@ -384,6 +386,7 @@ test_undefinedOutput = do if isFirst then return $ throw $ DeliberateException (userError "uhoh") else return $ defMessage & #id .~ req ^. #id + {------------------------------------------------------------------------------- Timeouts -------------------------------------------------------------------------------} diff --git a/grapesy/test-grapesy/Test/Sanity/Interop.hs b/grapesy/test-grapesy/Test/Sanity/Interop.hs index 6a8363b6..9645e0d1 100644 --- a/grapesy/test-grapesy/Test/Sanity/Interop.hs +++ b/grapesy/test-grapesy/Test/Sanity/Interop.hs @@ -216,7 +216,7 @@ test_cancellation_client :: IO () test_cancellation_client = testClientServer ClientServerTest { config = def { - expectEarlyClientTermination = True + isExpectedServerException = isClientDisconnected } , client = simpleTestClient $ \conn -> do -- We wait for the first input, but then cancel the request @@ -245,7 +245,7 @@ test_cancellation_server :: IO () test_cancellation_server = testClientServer ClientServerTest { config = def { - expectEarlyServerTermination = True + isExpectedServerException = isHandlerTerminated } , client = simpleTestClient $ \conn -> do result :: Either GrpcException [Int] <- try $ diff --git a/grapesy/test-grapesy/Test/Sanity/Reclamation.hs b/grapesy/test-grapesy/Test/Sanity/Reclamation.hs index 9a47ca7b..17608fde 100644 --- a/grapesy/test-grapesy/Test/Sanity/Reclamation.hs +++ b/grapesy/test-grapesy/Test/Sanity/Reclamation.hs @@ -32,7 +32,7 @@ brokenHandler _call = throwIO $ DeliberateException $ userError "Broken handler" serverException1 :: Assertion serverException1 = testClientServer $ ClientServerTest { - config = def + config = def { isExpectedServerException = isDeliberateException } , server = [Server.someRpcHandler $ Server.mkRpcHandler brokenHandler] , client = \params testServer delimitTestScope -> delimitTestScope $ replicateM_ 1000 $ do @@ -46,7 +46,7 @@ serverException1 = testClientServer $ ClientServerTest { serverException2 :: Assertion serverException2 = testClientServer $ ClientServerTest { - config = def + config = def { isExpectedServerException = isDeliberateException } , server = [Server.someRpcHandler $ Server.mkRpcHandler brokenHandler] , client = \params testServer delimitTestScope -> delimitTestScope $ replicateM_ 1000 $ diff --git a/grapesy/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs b/grapesy/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs index b334d13a..d32f1036 100644 --- a/grapesy/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs +++ b/grapesy/test-grapesy/Test/Sanity/StreamingType/NonStreaming.hs @@ -45,14 +45,22 @@ tests = testGroup "Test.Sanity.StreamingType.NonStreaming" [ , testGroup "fail" [ testCase "application/invalid-subtype" $ test_increment def { - clientContentType = InvalidOverride . Just $ + isExpectedServerException = + isInvalidRequestHeaders + , isExpectedClientException = + isGrpc415 + , clientContentType = InvalidOverride . Just $ ContentTypeOverride "application/invalid-subtype" } -- gRPC spec does not allow parameters , testCase "charset" $ test_increment def { - clientContentType = InvalidOverride . Just $ + isExpectedServerException = + isInvalidRequestHeaders + , isExpectedClientException = + isGrpc415 + , clientContentType = InvalidOverride . Just $ ContentTypeOverride "application/grpc; charset=utf-8" } ] @@ -71,11 +79,17 @@ tests = testGroup "Test.Sanity.StreamingType.NonStreaming" [ , testGroup "fail" [ testCase "validation" $ test_increment def { - useTLS = Just $ TlsFail TlsFailValidation + isExpectedClientException = + isHandshakeFailed + , useTLS = + Just $ TlsFail TlsFailValidation } , testCase "unsupported" $ test_increment def { - useTLS = Just $ TlsFail TlsFailUnsupported + isExpectedClientException = + isHandshakeFailed + , useTLS = + Just $ TlsFail TlsFailUnsupported } ] ] @@ -94,13 +108,23 @@ tests = testGroup "Test.Sanity.StreamingType.NonStreaming" [ , testGroup "unsupported" [ testCase "clientChoosesUnsupported" $ test_increment def { - clientInitCompr = Just Compr.gzip - , serverCompr = Compr.none + isExpectedServerException = + isServerUnsupportedCompression + , isExpectedClientException = + isGrpc400 + , clientInitCompr = + Just Compr.gzip + , serverCompr = + Compr.none } , testCase "serverChoosesUnsupported" $ test_increment def { - clientCompr = Compr.none - , serverCompr = Compr.insist Compr.gzip + isExpectedClientException = + isClientUnsupportedCompression + , clientCompr = + Compr.none + , serverCompr = + Compr.insist Compr.gzip } ] ]