diff --git a/grpc-mqtt.cabal b/grpc-mqtt.cabal index bc45795..0f07408 100644 --- a/grpc-mqtt.cabal +++ b/grpc-mqtt.cabal @@ -25,7 +25,7 @@ common common ghc-options: -Wall -Wcompat - -Werror + -- -Werror -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns @@ -36,6 +36,7 @@ common common -Wunused-packages -Wno-unused-top-binds -fshow-warning-groups + -eventlog default-extensions: BangPatterns BlockArguments DataKinds DefaultSignatures DeriveDataTypeable @@ -149,7 +150,7 @@ test-suite test -O2 -threaded -rtsopts - "-with-rtsopts=-N4" + "-with-rtsopts=-N4 -hT -ls -l -i0.005" -fregs-iterative other-modules: @@ -172,6 +173,8 @@ test-suite test Test.Service Test.Suite.Config Test.Suite.Fixture + Test.Suite.GRPC + Test.Suite.MQTT Test.Suite.Wire Test.Proto.Clients Test.Proto.RemoteClients @@ -196,5 +199,7 @@ test-suite test , tasty-hedgehog < 1.1.0.0 , tasty-hunit , tls + , unliftio >= 0.2.15 && < 0.3 + , unliftio-core >= 0.2.0 && < 0.3 , uuid , containers diff --git a/test/Test/Network/GRPC/MQTT/Message/Request.hs b/test/Test/Network/GRPC/MQTT/Message/Request.hs index 4fd8d95..e564509 100644 --- a/test/Test/Network/GRPC/MQTT/Message/Request.hs +++ b/test/Test/Network/GRPC/MQTT/Message/Request.hs @@ -9,7 +9,7 @@ where -------------------------------------------------------------------------------- import Hedgehog (Property, forAll, property, tripping, (===)) -import Hedgehog qualified as Hedgehog +import Hedgehog qualified import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) diff --git a/test/Test/Service.hs b/test/Test/Service.hs index b73c535..0608f65 100644 --- a/test/Test/Service.hs +++ b/test/Test/Service.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeApplications #-} -- | @@ -34,14 +36,10 @@ import Network.GRPC.HighLevel.Client WritesDone, ) import Network.GRPC.HighLevel.Client qualified as GRPC.Client -import Network.GRPC.HighLevel.Generated - ( GRPCMethodType (BiDiStreaming, ClientStreaming, Normal, ServerStreaming), - StatusCode (StatusOk), - withGRPCClient, - ) +import Network.GRPC.HighLevel.Generated (StatusCode (StatusOk), withGRPCClient) import Network.GRPC.Unsafe qualified as GRPC.Unsafe -import Network.MQTT.Client (QoS (QoS1), publishq) +import Network.MQTT.Client (QoS (QoS1), publishq, Topic) import Relude hiding (reader) @@ -72,7 +70,7 @@ import Test.Proto.RemoteClients (testServiceRemoteClientMethodMap) import Test.Proto.Service (newTestService) import Data.ByteString qualified as ByteString -import Proto.Message (BiDiRequestReply, OneInt, StreamReply, TwoInts) +import Proto.Message (BiDiRequestReply, OneInt, StreamReply) import Proto.Message qualified as Message import Proto.Service ( TestService @@ -87,10 +85,10 @@ import Proto.Service testServicecallLongBytes, ) -import Data.UUID qualified as UUID -import Data.UUID.V4 qualified as UUID - -import Data.Map.Strict qualified as Map +import Hedgehog (evalIO, property, withTests, (===)) +import Hedgehog qualified +import Test.Suite.MQTT (withTestMQTTGRPCClient, withPartialTestMQTTGRPCClient) +import Test.Tasty.Hedgehog (testProperty) -------------------------------------------------------------------------------- @@ -98,11 +96,23 @@ tests :: TestTree tests = testGroup "Service" - [ after Test.AllSucceed "MQTT" testTreeNormal - , after Test.AllSucceed "Normal" testTreeClientStream - , after Test.AllSucceed "ClientStream" testTreeServerStream - , after Test.AllSucceed "ServerStream" testTreeBiDiStream - , after Test.AllSucceed "BiDiStream" testTreeErrors + [ withTestMQTTGRPCClient \initClient topic -> + testGroup + "Pass" + [ testNormalCall initClient topic + , after Test.AllSucceed "Unary.Normal" (testLongBytes initClient topic) + , after Test.AllSucceed "Unary.LongBytes" (testClientStreamCall initClient topic) + , after Test.AllSucceed "Client.Unbatched" (testBatchClientStreamCall initClient topic) + , after Test.AllSucceed "Client.Batched" (testServerStreamCall initClient topic) + , after Test.AllSucceed "Server.Unbatched" (testBatchServerStreamCall initClient topic) + , after Test.AllSucceed "Server.Batched" (testBiDiStreamCall initClient topic) + , after Test.AllSucceed "BiDi.Unbatched" (testBatchBiDiStreamCall initClient topic) + ] + , testGroup + "Fail" + [ after Test.AllSucceed "Pass" testTimeoutClientNoGRPC + , after Test.AllSucceed "Timeout" testPublishBadTopic + ] ] withTestService :: (Async () -> IO a) -> Fixture a @@ -135,193 +145,229 @@ withServiceFixture k = do -------------------------------------------------------------------------------- -testTreeNormal :: TestTree -testTreeNormal = - testGroup - "Normal" - [ Suite.testFixture "LongBytes" testCallLongBytes - , after - Test.AllSucceed - "LongBytes" - (Suite.testFixture "Call" testNormalCall) - ] - -testCallLongBytes :: Fixture () -testCallLongBytes = do - configGRPC <- Suite.askConfigClientGRPC - remoteConfig <- Suite.askRemoteConfigMQTT - clientConfig <- Suite.askClientConfigMQTT - baseTopic <- asks Suite.testConfigBaseTopic - - withTestService \_ -> do - withGRPCClient configGRPC \grpcClient -> do - methods <- testServiceRemoteClientMethodMap grpcClient - result <- Async.withAsync (runRemoteClient logger remoteConfig baseTopic methods) \_ -> do - withMQTTGRPCClient logger clientConfig \client -> do - -- For uniquely identifying requests to the server. - uuid <- UUID.nextRandom - - -- NB: 2022-08-02 we discovered a bug with concurrent client - -- requests that send responses which, when sent back by the - -- server trigger a GRPCIOTimeout error in some of the clients. - let msg = Message.OneInt 64 - let rqt = GRPC.MQTT.MQTTNormalRequest msg 300 (GRPC.Client.MetadataMap (Map.fromList [("rqt-uuid", [UUID.toASCIIBytes uuid])])) - - testServicecallLongBytes (testServiceMqttClient client baseTopic) rqt - - liftIO case result of - GRPCResult (ClientNormalResponse (Message.BytesResponse x) _ms0 _ms1 _stat _details) -> do - print (ByteString.length x) - GRPCResult (ClientErrorResponse err) -> do - assertFailure (show err) - MQTTError err -> do - error err - where - logger :: Logger - logger = Logger print GRPC.MQTT.Logging.Silent - -testNormalCall :: Fixture () -testNormalCall = do - let msg = Message.TwoInts 5 10 - let rqt = GRPC.MQTT.MQTTNormalRequest msg 5 mempty - rsp <- makeMethodCall testServicenormalCall rqt +testNormalCall :: IO MQTTGRPCClient -> Topic -> TestTree +testNormalCall initClient topic = + (testProperty "Unary.Normal" . withTests 1 . property) do + let msg = Message.TwoInts 5 10 + let rqt = GRPC.MQTT.MQTTNormalRequest msg 5 mempty - checkNormalResponse msg rsp + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServicenormalCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientNormalResponse oneInt _ _ status _) -> do + status === StatusOk + oneInt === Message.OneInt 15 + +testLongBytes :: IO MQTTGRPCClient -> Topic -> TestTree +testLongBytes initClient topic = + (testProperty "Unary.LongBytes" . withTests 1 . property) do + let msg = Message.OneInt 64 + let rqt = GRPC.MQTT.MQTTNormalRequest msg 5 [] + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServicecallLongBytes (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientNormalResponse rsp _ _ status _) -> do + status === StatusOk + rsp === Message.BytesResponse (ByteString.replicate (1_000_000 * 64) 1) -------------------------------------------------------------------------------- -testTreeClientStream :: TestTree -testTreeClientStream = - testGroup - "ClientStream" - [ Suite.testFixture "Test.Service.ClientStream.Unbatched" testClientStreamCall - , after - Test.AllSucceed - "Test.Service.ClientStream.Unbatched" - (Suite.testFixture "Batched" testBatchClientStreamCall) - ] - -testClientStreamCall :: Fixture () -testClientStreamCall = do - let msg = map Message.OneInt [1 .. 5] - let rqt = GRPC.MQTT.MQTTWriterRequest 5 mempty (clientStreamHandler msg) - - rsp <- makeMethodCall testServiceClientStreamCall rqt - - checkClientStreamResponse msg rsp +testClientStreamCall :: IO MQTTGRPCClient -> Topic -> TestTree +testClientStreamCall initClient topic = + (testProperty "Client.Unbatched" . withTests 1 . property) do + let rqt = GRPC.MQTT.MQTTWriterRequest 30 mempty (clientStreamHandler ints) + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServiceClientStreamCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientWriterResponse rsp _ _ status _) -> do + status === StatusOk + rsp === expectation + where + expectation :: Maybe OneInt + expectation = Just (foldr plusOneInt (Message.OneInt 0) ints) + + plusOneInt :: OneInt -> OneInt -> OneInt + plusOneInt (Message.OneInt x) (Message.OneInt y) = Message.OneInt (x + y) -testBatchClientStreamCall :: Fixture () -testBatchClientStreamCall = do - let msg = map Message.OneInt [1 .. 5] - let rqt = GRPC.MQTT.MQTTWriterRequest 10 mempty (clientStreamHandler msg) - rsp <- makeMethodCall testServiceBatchClientStreamCall rqt + ints :: [OneInt] + ints = map Message.OneInt [1 .. 5] + +testBatchClientStreamCall :: IO MQTTGRPCClient -> Topic -> TestTree +testBatchClientStreamCall initClient topic = + (testProperty "Client.Batched" . withTests 1 . property) do + let rqt = GRPC.MQTT.MQTTWriterRequest 10 mempty (clientStreamHandler ints) + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServiceBatchClientStreamCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientWriterResponse rsp _ _ status _) -> do + status === StatusOk + rsp === expectation + where + expectation :: Maybe OneInt + expectation = Just (foldr plusOneInt (Message.OneInt 0) ints) + + plusOneInt :: OneInt -> OneInt -> OneInt + plusOneInt (Message.OneInt x) (Message.OneInt y) = Message.OneInt (x + y) - checkClientStreamResponse msg rsp + ints :: [OneInt] + ints = map Message.OneInt [1 .. 5] -------------------------------------------------------------------------------- -testTreeServerStream :: TestTree -testTreeServerStream = - testGroup - "ServerStream" - [ Suite.testFixture "Test.Service.ServerStream.Unbatched" testServerStreamCall - , after - Test.AllSucceed - "Test.Service.ServerStream.Unbatched" - (Suite.testFixture "Test.Service.ServerStream.Batched" testBatchServerStreamCall) - ] - -testServerStreamCall :: Fixture () -testServerStreamCall = do - buffer <- liftIO $ newIORef Seq.empty - - let msg = Message.StreamRequest "Alice" 100 - let rqt = MQTTReaderRequest msg 100 mempty (serverStreamHandler buffer) - rsp <- makeMethodCall testServiceServerStreamCall rqt - - let expected :: Seq StreamReply - expected = fmap (\(n :: Int) -> Message.StreamReply ("Alice" <> show n)) (Seq.fromList [1 .. 100]) - in checkServerStreamResponse rsp expected buffer - -testBatchServerStreamCall :: Fixture () -testBatchServerStreamCall = do - buffer <- liftIO $ newIORef Seq.empty - - let msg = Message.StreamRequest "Alice" 100 - let rqt = MQTTReaderRequest msg 300 mempty (serverStreamHandler buffer) - rsp <- makeMethodCall testServiceBatchServerStreamCall rqt - - let expected :: Seq StreamReply - expected = fmap (\(n :: Int) -> Message.StreamReply ("Alice" <> show n)) (Seq.fromList [1 .. 100]) - in checkServerStreamResponse rsp expected buffer +testServerStreamCall :: IO MQTTGRPCClient -> Topic -> TestTree +testServerStreamCall initClient topic = + (testProperty "Server.Unbatched" . withTests 1 . property) do + buffer <- liftIO $ newIORef Seq.empty + + let msg = Message.StreamRequest "Alice" 100 + let rqt = MQTTReaderRequest msg 100 mempty (serverStreamHandler buffer) + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServiceServerStreamCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientReaderResponse _ status _) -> do + actual <- readIORef buffer + actual === expected + status === StatusOk + where + expected :: Seq StreamReply + expected = fmap (\(n :: Int) -> Message.StreamReply ("Alice" <> show n)) (Seq.fromList [1 .. 100]) + +testBatchServerStreamCall :: IO MQTTGRPCClient -> Topic -> TestTree +testBatchServerStreamCall initClient topic = + (testProperty "Server.Batched" . withTests 1 . property) do + buffer <- liftIO $ newIORef Seq.empty + + let msg = Message.StreamRequest "Alice" 100 + let rqt = MQTTReaderRequest msg 300 mempty (serverStreamHandler buffer) + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServiceBatchServerStreamCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientReaderResponse _ status _) -> do + actual <- readIORef buffer + actual === expected + status === StatusOk + where + expected :: Seq StreamReply + expected = fmap (\(n :: Int) -> Message.StreamReply ("Alice" <> show n)) (Seq.fromList [1 .. 100]) -------------------------------------------------------------------------------- -testTreeBiDiStream :: TestTree -testTreeBiDiStream = - testGroup - "BiDiStream" - [ Suite.testFixture "Test.Service.BiDiStream.Unbatched" testBiDiStreamCall - , after - Test.AllSucceed - "Test.Service.BiDiStream.Unbatched" - (Suite.testFixture "Batched" testBatchBiDiStreamCall) - ] - -testBiDiStreamCall :: Fixture () -testBiDiStreamCall = do - let rqt = MQTTBiDiRequest 10 mempty bidiStreamHandler - rsp <- makeMethodCall testServiceBiDiStreamCall rqt - - checkBiDiStreamResponse rsp - -testBatchBiDiStreamCall :: Fixture () -testBatchBiDiStreamCall = do - let rqt = MQTTBiDiRequest 10 mempty bidiStreamHandler - rsp <- makeMethodCall testServiceBatchBiDiStreamCall rqt - - checkBiDiStreamResponse rsp +testBiDiStreamCall :: IO MQTTGRPCClient -> Topic -> TestTree +testBiDiStreamCall initClient topic = + (testProperty "BiDi.Unbatched" . withTests 1 . property) do + let rqt = MQTTBiDiRequest 10 mempty bidiStreamHandler + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServiceBiDiStreamCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientBiDiResponse _ status _) -> do + status === StatusOk + +testBatchBiDiStreamCall :: IO MQTTGRPCClient -> Topic -> TestTree +testBatchBiDiStreamCall initClient topic = + (testProperty "BiDi.Batched" . withTests 1 . property) do + let rqt = MQTTBiDiRequest 15 mempty bidiStreamHandler + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServiceBatchBiDiStreamCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientBiDiResponse _ status _) -> do + status === StatusOk -------------------------------------------------------------------------------- testTreeErrors :: TestTree testTreeErrors = - let timeout :: TestTree - timeout = Suite.testFixture "Test.Service.Errors.Timeout" testClientTimeout - - missing :: TestTree + let missing :: TestTree missing = Suite.testFixture "Test.Service.Errors.Missing" testMissingClientMethod - - malform :: TestTree - malform = Suite.testFixture "Test.Service.Errors.Malform" testMalformedMessage in testGroup "Test.Service.Errors" - [ timeout - , after Test.AllSucceed "Errors.Timeout" missing - , after Test.AllSucceed "Errors.Missing" malform + [ + after Test.AllSucceed "Errors.Timeout" missing ] -testClientTimeout :: Fixture () -testClientTimeout = do - clientConfig <- Suite.askClientConfigMQTT - baseTopic <- asks Suite.testConfigBaseTopic - - rsp <- liftIO $ withMQTTGRPCClient logger clientConfig \client -> do - let msg = Message.TwoInts 5 10 - let rqt = GRPC.MQTT.MQTTNormalRequest msg 5 mempty - testServicenormalCall (testServiceMqttClient client baseTopic) rqt - - liftIO case rsp of - MQTTError err -> do - assertFailure (show err) - GRPCResult (ClientNormalResponse result _ _ _ _) -> do - assertFailure (show result) - GRPCResult (ClientErrorResponse err) -> do - err @?= expectation +testTimeoutClientNoGRPC :: TestTree +testTimeoutClientNoGRPC = + withPartialTestMQTTGRPCClient \initClient topic -> + (testProperty "Timeout.gRPC" . withTests 1 . property) do + let msg = Message.TwoInts 5 10 + let rqt = GRPC.MQTT.MQTTNormalRequest msg 5 mempty + + client <- Hedgehog.evalIO initClient + result <- Hedgehog.evalIO (testServicenormalCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + exn === expectation + GRPCResult (ClientNormalResponse rsp _ _ _ _) -> do + Hedgehog.footnoteShow rsp + Hedgehog.failure where - logger :: Logger - logger = Logger print GRPC.MQTT.Logging.Silent - expectation :: GRPC.Client.ClientError expectation = GRPC.Client.ClientIOError GRPC.GRPCIOTimeout @@ -360,118 +406,37 @@ testMissingClientMethod = do expectation :: GRPC.Client.ClientError expectation = GRPC.Client.ClientIOError (GRPC.GRPCIOCallError GRPC.Unsafe.CallError) -testMalformedMessage :: Fixture () -testMalformedMessage = do - configGRPC <- Suite.askConfigClientGRPC - remoteConfig <- Suite.askRemoteConfigMQTT - clientConfig <- Suite.askClientConfigMQTT - baseTopic <- asks Suite.testConfigBaseTopic - - let msg = Message.TwoInts 5 10 - let rqt = GRPC.MQTT.MQTTNormalRequest msg 5 mempty - - rsp <- withTestService \_ -> do - withGRPCClient configGRPC \clientGRPC -> do - methods <- testServiceRemoteClientMethodMap clientGRPC - let remoteClient = runRemoteClient logger remoteConfig baseTopic methods - Async.withAsync remoteClient \_ -> do - withMQTTGRPCClient logger clientConfig \clientMQTT -> do - -- Send a malformed message to an unknown topic - publishq (GRPC.MQTT.Client.mqttClient clientMQTT) (baseTopic <> "bad") "blah" False QoS1 [] - sleep 1 - - -- Make a well-formed request to ensure the previous request did not - -- take down the service - testServicenormalCall (testServiceMqttClient clientMQTT baseTopic) rqt - - checkNormalResponse msg rsp - where - logger :: Logger - logger = Logger print GRPC.MQTT.Logging.Debug - --------------------------------------------------------------------------------- - -checkNormalResponse :: TwoInts -> MQTTResult 'Normal OneInt -> Fixture () -checkNormalResponse (Message.TwoInts x y) rsp = - liftIO case rsp of - MQTTError err -> do - assertFailure (show err) - GRPCResult (ClientErrorResponse err) -> do - assertFailure (show err) - GRPCResult (ClientNormalResponse result _ _ status _) -> do - status @?= StatusOk - result @?= expectation - where - expectation :: OneInt - expectation = Message.OneInt (x + y) - -checkClientStreamResponse :: - [OneInt] -> - MQTTResult 'ClientStreaming OneInt -> - Fixture () -checkClientStreamResponse ints rsp = - liftIO case rsp of - MQTTError err -> do - assertFailure (show err) - GRPCResult (ClientErrorResponse err) -> do - assertFailure (show err) - GRPCResult (ClientWriterResponse result _ _ status _) -> do - status @?= StatusOk - result @?= expectation - where - plusOneInt :: OneInt -> OneInt -> OneInt - plusOneInt (Message.OneInt x) (Message.OneInt y) = Message.OneInt (x + y) - - expectation :: Maybe OneInt - expectation = Just (foldr plusOneInt (Message.OneInt 0) ints) - -checkServerStreamResponse :: - MQTTResult 'ServerStreaming StreamReply -> - Seq StreamReply -> - IORef (Seq StreamReply) -> - Fixture () -checkServerStreamResponse rsp expected buffer = - liftIO case rsp of - MQTTError err -> do - assertFailure (show err) - GRPCResult (ClientErrorResponse err) -> do - assertFailure (show err) - GRPCResult (ClientReaderResponse _ status _) -> do - actual <- readIORef buffer - actual @?= expected - status @?= StatusOk - -checkBiDiStreamResponse :: - MQTTResult 'BiDiStreaming BiDiRequestReply -> - Fixture () -checkBiDiStreamResponse rsp = - liftIO case rsp of - MQTTError err -> do - assertFailure (show err) - GRPCResult (ClientErrorResponse err) -> do - assertFailure (show err) - GRPCResult (ClientBiDiResponse _ status _) -> do - status @?= StatusOk - --------------------------------------------------------------------------------- - -type Handler s rqt rsp = MQTTRequest s rqt rsp -> IO (MQTTResult s rsp) - -makeMethodCall :: - (TestService MQTTRequest MQTTResult -> Handler s rqt rsp) -> - MQTTRequest s rqt rsp -> - Fixture (MQTTResult s rsp) -makeMethodCall method request = do - baseTopic <- asks Suite.testConfigBaseTopic - withServiceFixture \_ client -> do - method (testServiceMqttClient client baseTopic) request +testPublishBadTopic :: TestTree +testPublishBadTopic = do + withTestMQTTGRPCClient \initClient topic -> + (testProperty "Bad-Topic" . withTests 1 . property) do + let msg = Message.TwoInts 5 10 + let rqt = GRPC.MQTT.MQTTNormalRequest msg 5 mempty + + client <- Hedgehog.evalIO initClient + + -- Send a malformed message to an unknown topic + Hedgehog.evalIO (publishq (GRPC.MQTT.Client.mqttClient client) (topic <> "bad") "blah" False QoS1 []) + + -- Make a well-formed request to ensure the previous request did not + -- take down the service + result <- Hedgehog.evalIO (testServicenormalCall (testServiceMqttClient client topic) rqt) + + case result of + MQTTError exn -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientErrorResponse exn) -> do + Hedgehog.footnoteShow exn + Hedgehog.failure + GRPCResult (ClientNormalResponse rsp _ _ _ _) -> do + Hedgehog.footnoteShow rsp + rsp === Message.OneInt 15 -------------------------------------------------------------------------------- clientStreamHandler :: [OneInt] -> GRPC.Client.StreamSend OneInt -> IO () -clientStreamHandler ints send = - forM_ ints \int -> do - send int +clientStreamHandler ints send = traverse_ send ints serverStreamHandler :: IORef (Seq StreamReply) -> @@ -501,6 +466,7 @@ bidiStreamHandler _ recv send done = do sender = do results <- sequence + @[] [ send (Message.BiDiRequestReply "Alice1Alice1Alice1") , send (Message.BiDiRequestReply "Alice2") , send (Message.BiDiRequestReply "Alice3Alice3Alice3") diff --git a/test/Test/Suite/GRPC.hs b/test/Test/Suite/GRPC.hs new file mode 100644 index 0000000..8afe53a --- /dev/null +++ b/test/Test/Suite/GRPC.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | This module exports "grpc-mqtt" test suite helpers for managing gRPC +-- servers within tasty tests. +module Test.Suite.GRPC + ( withServer, + -- withTestService, + withTestClient, + -- withTestGRPC, + ) +where + +import Network.GRPC.LowLevel.Client qualified as GRPC +import Network.GRPC.HighLevel (ServiceOptions) +import Network.GRPC.LowLevel.GRPC (GRPC) +import Network.GRPC.LowLevel.GRPC qualified as GRPC + +import Relude + +import Test.Proto.Service (newTestService) + +import Test.Suite.Config qualified as Test.Config + +import Test.Tasty (TestTree, withResource) + +import Text.Printf (printf) + +import UnliftIO.Async (Async) +import UnliftIO.Async qualified as Async + +-------------------------------------------------------------------------------- + +withServer :: (IO (Async ()) -> IO GRPC.Client -> TestTree) -> TestTree +withServer k = withTestService (withTestClient . k) + +-- | TODO +withTestService :: (IO (Async ()) -> TestTree) -> TestTree +withTestService k = + Test.Config.withTestConfig do + serviceOptions <- Test.Config.askServiceOptions + pure (withResource (onInit serviceOptions) onDone k) + where + onInit :: ServiceOptions -> IO (Async ()) + onInit serviceOptions = do + printf "withTestService: initializing gRPC test server.\n" + Async.async (newTestService serviceOptions) + + onDone :: Async () -> IO () + onDone thread = do + printf "withTestService: shutting down gRPC test server.\n" + Async.cancel thread + +-- | TODO +withTestClient :: (IO GRPC.Client -> TestTree) -> TestTree +withTestClient k = + Test.Config.withTestConfig do + config <- Test.Config.askConfigClientGRPC + pure $ withTestGRPC \initGRPC -> + withResource (onInit initGRPC config) onDone k + where + onInit :: IO GRPC -> GRPC.ClientConfig -> IO GRPC.Client + onInit initGRPC config = do + printf "withTestGRPC: initializing gRPC-haskell client.\n" + grpc <- initGRPC + GRPC.createClient grpc config + + onDone :: GRPC.Client -> IO () + onDone client = do + printf "withTestGRPC: shutting down gRPC-haskell client.\n" + GRPC.destroyClient client + +-- | Creates an IO action that initializes gRPC core on a seperate thread and +-- passes that action, which returns the 'Async' handling the gRPC server, to +-- the continuation function. +-- +-- The gRPC server will only start when the IO action is evaluated. +-- +-- Shutdown of the gRPC server is handled when the continuation function is +-- completed or an exception is raised, either by gRPC-haskell-core or the +-- continuation. +withTestGRPC :: (IO GRPC -> TestTree) -> TestTree +withTestGRPC = withResource onInit onDone + where + onInit :: IO GRPC + onInit = do + printf "withTestGRPC: initializing gRPC-haskell-core.\n" + GRPC.startGRPC + + onDone :: GRPC -> IO () + onDone grpc = do + printf "withTestGRPC: shutting down gRPC-haskell-core.\n" + GRPC.stopGRPC grpc diff --git a/test/Test/Suite/MQTT.hs b/test/Test/Suite/MQTT.hs new file mode 100644 index 0000000..a2b2f8c --- /dev/null +++ b/test/Test/Suite/MQTT.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE TemplateHaskellQuotes #-} + +-- | This module exports "grpc-mqtt" test suite helpers for managing gRPC-MQTT +-- clients and remote clients within tasty tests. +module Test.Suite.MQTT + ( withTestMQTTGRPCClient, + withPartialTestMQTTGRPCClient, + withTestRemoteClient, + ) +where + +import Network.GRPC.HighLevel.Client (Client) +import Network.GRPC.MQTT (Topic) +import Network.GRPC.MQTT.Client + ( MQTTGRPCClient, + connectMQTTGRPC, + disconnectMQTTGRPC, + ) +import Network.GRPC.MQTT.Core (MQTTGRPCConfig) +import Network.GRPC.MQTT.Logging (Logger (..), Verbosity (..)) +import Network.GRPC.MQTT.RemoteClient (runRemoteClient) + +import Relude + +import Test.Proto.RemoteClients (testServiceRemoteClientMethodMap) + +import Test.Suite.Config qualified as Test.Config +import Test.Suite.GRPC (withServer) + +import Test.Tasty (TestTree, withResource) + +import Text.Printf (printf) + +import Turtle (sleep) + +import UnliftIO.Async (Async) +import UnliftIO.Async qualified as Async + +-------------------------------------------------------------------------------- + +makeTestLogger :: Logger +makeTestLogger = Logger print Silent + +-- | TODO +withTestMQTTGRPCClient :: (IO MQTTGRPCClient -> Topic -> TestTree) -> TestTree +withTestMQTTGRPCClient k = + withTestRemoteClient \initService -> Test.Config.withTestConfig do + config <- Test.Config.askConfigMQTT + topic <- asks Test.Config.testConfigBaseTopic + pure (withResource (onInit initService config) onDone (`k` topic)) + where + onInit :: IO (Async ()) -> MQTTGRPCConfig -> IO MQTTGRPCClient + onInit initService config = do + printf "withTestMQTTGRPCClient: initializing gRPC-MQTT client.\n" + void initService + sleep 1 + connectMQTTGRPC makeTestLogger config + + onDone :: MQTTGRPCClient -> IO () + onDone client = do + printf "withTestMQTTGRPCClient: disconnecting gRPC-MQTT client.\n" + disconnectMQTTGRPC client + +-- | TODO +withPartialTestMQTTGRPCClient :: (IO MQTTGRPCClient -> Topic -> TestTree) -> TestTree +withPartialTestMQTTGRPCClient k = + Test.Config.withTestConfig do + config <- Test.Config.askConfigMQTT + topic <- asks Test.Config.testConfigBaseTopic + pure (withResource (onInit config) onDone (`k` topic)) + where + onInit :: MQTTGRPCConfig -> IO MQTTGRPCClient + onInit config = do + printf "withTestMQTTGRPCClient: initializing partial gRPC-MQTT client.\n" + connectMQTTGRPC makeTestLogger config + + onDone :: MQTTGRPCClient -> IO () + onDone client = do + printf "withTestMQTTGRPCClient: disconnecting partial gRPC-MQTT client.\n" + disconnectMQTTGRPC client + +-- | TODO +withTestRemoteClient :: (IO (Async ()) -> TestTree) -> TestTree +withTestRemoteClient k = + withServer \initGrpc initGrpcClient -> Test.Config.withTestConfig do + config <- Test.Config.askRemoteConfigMQTT + topic <- Test.Config.testConfigBaseTopic + pure (withResource (onInit initGrpc initGrpcClient config topic) onDone k) + where + onInit :: IO (Async ()) -> IO Client -> MQTTGRPCConfig -> Topic -> IO (Async ()) + onInit initGrpc initGrpcClient config topic = do + printf "withTestRemoteClient: initializing gRPC-MQTT remote client.\n" + void initGrpc + client <- initGrpcClient + method <- testServiceRemoteClientMethodMap client + Async.async (runRemoteClient makeTestLogger config topic method) + + onDone :: Async () -> IO () + onDone thread = do + printf "withTestRemoteClient: disconnecting gRPC-MQTT remote client.\n" + -- better error handling/async polling + Async.cancel thread \ No newline at end of file