From 7a9648ca353b71215cb648eb3c5bc86a0eb63967 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Sun, 20 Oct 2024 09:33:07 +0200 Subject: [PATCH 1/2] Significantly relax upper bounds on stress servers Memory usage on my machine was significantly higher for whatever reason, hovering around 200 MB (heap, not live data, that was _waaay_ less). So set the limit at double that. --- grapesy/test-stress/Test/Stress/Driver.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/grapesy/test-stress/Test/Stress/Driver.hs b/grapesy/test-stress/Test/Stress/Driver.hs index af1211e..db934d1 100644 --- a/grapesy/test-stress/Test/Stress/Driver.hs +++ b/grapesy/test-stress/Test/Stress/Driver.hs @@ -236,7 +236,7 @@ servers = [ , componentPort = 50000 , componentSecure = False , componentStable = False - , componentLimit = Just 60 + , componentLimit = Just 400 , componentName = "server-unstable-insecure" } , Component { @@ -244,7 +244,7 @@ servers = [ , componentPort = 50001 , componentSecure = True , componentStable = False - , componentLimit = Just 100 + , componentLimit = Just 400 , componentName = "server-unstable-secure" } , Component { @@ -252,7 +252,7 @@ servers = [ , componentPort = 50002 , componentSecure = False , componentStable = True - , componentLimit = Just 60 + , componentLimit = Just 400 , componentName = "server-stable-insecure" } , Component { @@ -260,7 +260,7 @@ servers = [ , componentPort = 50003 , componentSecure = True , componentStable = True - , componentLimit = Just 100 + , componentLimit = Just 400 , componentName = "server-stable-secure" } ] From 3f58f07bc1e50a434ee4572001dbfb6e77a86d00 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Sun, 20 Oct 2024 10:08:28 +0200 Subject: [PATCH 2/2] Check that messages are well-formed before enqueue --- grapesy/grapesy.cabal | 2 + grapesy/kvstore/KVStore/API.hs | 4 +- grapesy/src/Network/GRPC/Common/NextElem.hs | 2 +- grapesy/src/Network/GRPC/Common/StreamElem.hs | 6 +- grapesy/src/Network/GRPC/Server/StreamType.hs | 8 +++ grapesy/src/Network/GRPC/Spec/MessageMeta.hs | 5 +- grapesy/src/Network/GRPC/Spec/RPC.hs | 14 ++++- grapesy/src/Network/GRPC/Spec/RPC/JSON.hs | 18 +++++- grapesy/src/Network/GRPC/Spec/RPC/Protobuf.hs | 8 +++ .../Test/Sanity/BrokenDeployments.hs | 55 +++++++++++++++++++ .../Test/Sanity/StreamingType/CustomFormat.hs | 3 + .../util/Network/GRPC/Util/Session/Channel.hs | 17 ++++-- 12 files changed, 126 insertions(+), 16 deletions(-) diff --git a/grapesy/grapesy.cabal b/grapesy/grapesy.cabal index 97b6663..b121426 100644 --- a/grapesy/grapesy.cabal +++ b/grapesy/grapesy.cabal @@ -351,6 +351,7 @@ test-suite test-grapesy , bytestring >= 0.10 && < 0.13 , case-insensitive >= 1.2 && < 1.3 , containers >= 0.6 && < 0.8 + , deepseq >= 1.4 && < 1.6 , exceptions >= 0.10 && < 0.11 , http-types >= 0.12 && < 0.13 , http2 >= 5.3.4 && < 5.4 @@ -636,6 +637,7 @@ benchmark grapesy-kvstore , base64-bytestring >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.13 , containers >= 0.6 && < 0.8 + , deepseq >= 1.4 && < 1.6 , hashable >= 1.3 && < 1.5 , optparse-applicative >= 0.16 && < 0.19 , proto-lens-runtime >= 0.7 && < 0.8 diff --git a/grapesy/kvstore/KVStore/API.hs b/grapesy/kvstore/KVStore/API.hs index d3077e9..095c0c1 100644 --- a/grapesy/kvstore/KVStore/API.hs +++ b/grapesy/kvstore/KVStore/API.hs @@ -8,6 +8,7 @@ module KVStore.API ( , KVStore(..) ) where +import Control.DeepSeq (NFData) import Control.Monad import Data.Aeson.Types qualified as Aeson import Data.ByteString (ByteString) @@ -25,13 +26,14 @@ newtype Key = Key { getKey :: ByteString } deriving stock (Show, Eq, Ord) - deriving newtype (Hashable) + deriving newtype (Hashable, NFData) deriving (ToJSON, FromJSON) via Base64 newtype Value = Value { getValue :: ByteString } deriving stock (Show, Eq, Ord) + deriving newtype (NFData) deriving (ToJSON, FromJSON) via Base64 {------------------------------------------------------------------------------- diff --git a/grapesy/src/Network/GRPC/Common/NextElem.hs b/grapesy/src/Network/GRPC/Common/NextElem.hs index 6e00869..ae561d3 100644 --- a/grapesy/src/Network/GRPC/Common/NextElem.hs +++ b/grapesy/src/Network/GRPC/Common/NextElem.hs @@ -26,7 +26,7 @@ import Network.GRPC.Common.StreamElem (StreamElem(..)) -- | Is there a next element in a stream? -- -- Does not record metadata, unlike 'Network.GRPC.Common.StreamElem.StreamElem'. -data NextElem a = NoNextElem | NextElem a +data NextElem a = NoNextElem | NextElem !a deriving stock (Show, Eq, Functor, Foldable, Traversable) {------------------------------------------------------------------------------- diff --git a/grapesy/src/Network/GRPC/Common/StreamElem.hs b/grapesy/src/Network/GRPC/Common/StreamElem.hs index b1ba3da..1e67138 100644 --- a/grapesy/src/Network/GRPC/Common/StreamElem.hs +++ b/grapesy/src/Network/GRPC/Common/StreamElem.hs @@ -45,12 +45,12 @@ data StreamElem b a = -- -- In this case, this element is /not/ final (and the final element, when -- we receive it, will be tagged as 'Final'). - StreamElem a + StreamElem !a -- | We received the final element -- -- The final element is annotated with some additional information. - | FinalElem a b + | FinalElem !a !b -- | There are no more elements -- @@ -59,7 +59,7 @@ data StreamElem b a = -- * The stream didn't contain any elements at all. -- * The final element was not marked as final. -- See 'StreamElem' for detailed additional discussion. - | NoMoreElems b + | NoMoreElems !b deriving stock (Show, Eq, Functor, Foldable, Traversable) instance Bifunctor StreamElem where diff --git a/grapesy/src/Network/GRPC/Server/StreamType.hs b/grapesy/src/Network/GRPC/Server/StreamType.hs index 5379aae..1665af8 100644 --- a/grapesy/src/Network/GRPC/Server/StreamType.hs +++ b/grapesy/src/Network/GRPC/Server/StreamType.hs @@ -288,6 +288,14 @@ data Services m (servs :: [[k]]) where -- -- > Server.fromMethod @EmptyCall $ ServerHandler $ \(_ ::Empty) -> -- > return (defMessage :: Empty) +-- +-- If the streaming type cannot be deduced, you might need to specify that also: +-- +-- > Server.fromMethod @Ping @NonStreaming $ ServerHandler $ .. +-- +-- Alternatively, use one of the handler construction functions, such as +-- +-- > Server.fromMethod @Ping $ Server.mkNonStreaming $ .. fromMethod :: forall rpc styp m. ( SupportsServerRpc rpc , ValidStreamingType styp diff --git a/grapesy/src/Network/GRPC/Spec/MessageMeta.hs b/grapesy/src/Network/GRPC/Spec/MessageMeta.hs index 98fe27a..12f8799 100644 --- a/grapesy/src/Network/GRPC/Spec/MessageMeta.hs +++ b/grapesy/src/Network/GRPC/Spec/MessageMeta.hs @@ -4,8 +4,10 @@ module Network.GRPC.Spec.MessageMeta ( , InboundMeta(..) ) where +import Control.DeepSeq (NFData) import Data.Default import Data.Word +import GHC.Generics (Generic) {------------------------------------------------------------------------------- Outbound messages @@ -18,7 +20,8 @@ data OutboundMeta = OutboundMeta { -- smaller message. outboundEnableCompression :: Bool } - deriving stock (Show) + deriving stock (Show, Generic) + deriving anyclass (NFData) instance Default OutboundMeta where def = OutboundMeta { diff --git a/grapesy/src/Network/GRPC/Spec/RPC.hs b/grapesy/src/Network/GRPC/Spec/RPC.hs index 3384461..95bf4e3 100644 --- a/grapesy/src/Network/GRPC/Spec/RPC.hs +++ b/grapesy/src/Network/GRPC/Spec/RPC.hs @@ -9,6 +9,7 @@ module Network.GRPC.Spec.RPC ( , defaultRpcContentType ) where +import Control.DeepSeq (NFData) import Data.ByteString qualified as Strict (ByteString) import Data.ByteString.Lazy qualified as Lazy import Data.Kind @@ -36,13 +37,22 @@ type family Output (rpc :: k) :: Type -- We therefore punt on the encoding issue here, and use bytestrings. /If/ -- applications want to use non-ASCII characters, they can choose their own -- encoding. -class ( -- Debug constraints +class ( -- Serialization + -- + -- We force messages to NF before enqueueing them. This ensures that + -- if those messages contain any pure exceptions (due to a bug in a + -- client or a server), we detect the problem when the message is + -- enqueued, and can throw an appropriate exception. + NFData (Input rpc) + , NFData (Output rpc) + + -- Debug constraints -- -- For debugging it is useful when we have 'Show' instances in scope. -- This is not that strong a requirement; after all, we must be able -- to serialize inputs and deserialize outputs, so they must also be -- 'Show'able. - Show (Input rpc) + , Show (Input rpc) , Show (Output rpc) , Show (RequestMetadata rpc) , Show (ResponseInitialMetadata rpc) diff --git a/grapesy/src/Network/GRPC/Spec/RPC/JSON.hs b/grapesy/src/Network/GRPC/Spec/RPC/JSON.hs index af11e1d..fc3b0fa 100644 --- a/grapesy/src/Network/GRPC/Spec/RPC/JSON.hs +++ b/grapesy/src/Network/GRPC/Spec/RPC/JSON.hs @@ -9,6 +9,7 @@ module Network.GRPC.Spec.RPC.JSON ( , Optional(..) ) where +import Control.DeepSeq (NFData(..)) import Data.Aeson (ToJSON(..), FromJSON(..), (.=), (.:), (.:?)) import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson @@ -59,6 +60,10 @@ data JsonRpc (serv :: Symbol) (meth :: Symbol) instance ( KnownSymbol serv , KnownSymbol meth + -- Serialization + , NFData (Input (JsonRpc serv meth)) + , NFData (Output (JsonRpc serv meth)) + -- Debugging constraints , Show (Input (JsonRpc serv meth)) , Show (Output (JsonRpc serv meth)) @@ -129,11 +134,19 @@ instance (Show x, Show (JsonObject fs)) . showString " :* " . showsPrec 6 xs +instance NFData (JsonObject '[]) where + rnf JsonObject = () + +instance (NFData x, NFData (JsonObject fs)) + => NFData (JsonObject ('(f, x) : fs)) where + rnf (x :* xs) = rnf (x, xs) + -- | Required field newtype Required a = Required { getRequired :: a } - deriving (Show) + deriving stock (Show) + deriving newtype (NFData) -- | Optional field -- @@ -141,7 +154,8 @@ newtype Required a = Required { newtype Optional a = Optional { getOptional :: Maybe a } - deriving (Show) + deriving stock (Show) + deriving newtype (NFData) infixr 5 :* diff --git a/grapesy/src/Network/GRPC/Spec/RPC/Protobuf.hs b/grapesy/src/Network/GRPC/Spec/RPC/Protobuf.hs index 82bd672..de8cc6b 100644 --- a/grapesy/src/Network/GRPC/Spec/RPC/Protobuf.hs +++ b/grapesy/src/Network/GRPC/Spec/RPC/Protobuf.hs @@ -9,6 +9,7 @@ module Network.GRPC.Spec.RPC.Protobuf ( , getProto ) where +import Control.DeepSeq (NFData) import Control.Lens hiding (lens) import Data.ByteString qualified as Strict (ByteString) import Data.ByteString.Char8 qualified as BS.Char8 @@ -51,9 +52,15 @@ type instance Input (Protobuf serv meth) = Proto (MethodInput serv meth) type instance Output (Protobuf serv meth) = Proto (MethodOutput serv meth) instance ( HasMethodImpl serv meth + + -- Debugging , Show (MethodInput serv meth) , Show (MethodOutput serv meth) + -- Serialization + , NFData (MethodInput serv meth) + , NFData (MethodOutput serv meth) + -- Metadata constraints , Show (RequestMetadata (Protobuf serv meth)) , Show (ResponseInitialMetadata (Protobuf serv meth)) @@ -144,6 +151,7 @@ newtype Proto msg = Proto msg , Enum , FieldDefault , MessageEnum + , NFData ) -- | Field accessor for 'Proto' diff --git a/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs b/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs index ec0ea9a..d5ff176 100644 --- a/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs +++ b/grapesy/test-grapesy/Test/Sanity/BrokenDeployments.hs @@ -1,19 +1,26 @@ -- Intentionally /NOT/ enabling OverloadedStrings. -- This forces us to be precise about encoding issues. +{-# LANGUAGE OverloadedLabels #-} + module Test.Sanity.BrokenDeployments (tests) where import Control.Exception import Data.ByteString.Char8 qualified as BS.Strict.Char8 import Data.ByteString.UTF8 qualified as BS.Strict.UTF8 +import Data.IORef import Data.Text qualified as Text import Network.HTTP.Types qualified as HTTP import Test.Tasty import Test.Tasty.HUnit 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.StreamType qualified as Server + +import Test.Driver.ClientServer import Test.Util.RawTestServer import Proto.API.Ping @@ -44,6 +51,9 @@ tests = testGroup "Test.Sanity.BrokenDeployments" [ , testCase "requestMetadata" test_invalidRequestMetadata , testCase "trailerMetadata" test_invalidTrailerMetadata ] + , testGroup "Undefined" [ + testCase "output" test_undefinedOutput + ] ] connParams :: Client.ConnParams @@ -324,3 +334,48 @@ grpcMessageContains GrpcException{grpcErrorMessage} str = case grpcErrorMessage of Just msg -> Text.pack str `Text.isInfixOf` msg Nothing -> False + +{------------------------------------------------------------------------------- + Undefined values +-------------------------------------------------------------------------------} + +test_undefinedOutput :: Assertion +test_undefinedOutput = do + st <- newIORef 0 + testClientServer $ ClientServerTest { + config = def + , server = [Server.fromMethod @Ping $ Server.mkNonStreaming (handler st)] + , client = simpleTestClient $ \conn -> do + + -- The first time the handler is invoked, it attempts to enqueue a + -- an undefined message (one containing a pure exception). Prior to + -- #235 this would result in undefined behaviour, probably the server + -- disconnecting. What should happen instead is that this exception + -- is thrown in the handler, caught, sent to the client as a + -- 'GrpcException', and re-raised in the client. + mResp1 :: Either GrpcException (Proto PongMessage) <- try $ + Client.nonStreaming conn (Client.rpc @Ping) (defMessage & #id .~ 1) + case mResp1 of + Left err | Just msg <- grpcErrorMessage err -> + assertBool "" $ Text.pack "uhoh" `Text.isInfixOf` msg + _otherwise -> + assertFailure "Unexpected response" + + -- Meanwhile, the server should just continue running; the /second/ + -- invocation of the handler should succeed normally. + mResp2 :: Either GrpcException (Proto PongMessage) <- try $ + Client.nonStreaming conn (Client.rpc @Ping) (defMessage & #id .~ 2) + case mResp2 of + Right resp -> + assertEqual "" 2 $ resp ^. #id + _otherwise -> + assertFailure "Unexpected response" + } + where + -- Server handler attempts to enqueue an undefined message + handler :: IORef Int -> Proto PingMessage -> IO (Proto PongMessage) + handler st req = do + isFirst <- atomicModifyIORef st $ \i -> (succ i, i == 0) + if isFirst + then return $ throw $ DeliberateException (userError "uhoh") + else return $ defMessage & #id .~ req ^. #id diff --git a/grapesy/test-grapesy/Test/Sanity/StreamingType/CustomFormat.hs b/grapesy/test-grapesy/Test/Sanity/StreamingType/CustomFormat.hs index 23475e4..f009663 100644 --- a/grapesy/test-grapesy/Test/Sanity/StreamingType/CustomFormat.hs +++ b/grapesy/test-grapesy/Test/Sanity/StreamingType/CustomFormat.hs @@ -4,6 +4,7 @@ module Test.Sanity.StreamingType.CustomFormat (tests) where import Codec.Serialise qualified as Cbor import Control.Concurrent.Async (concurrently) +import Control.DeepSeq (NFData) import Data.Bifunctor import Data.ByteString qualified as Strict (ByteString) import Data.Kind @@ -59,6 +60,8 @@ data Function = class ( Typeable fun , Show (CalcInput fun) , Show (CalcOutput fun) + , NFData (CalcInput fun) + , NFData (CalcOutput fun) , Cbor.Serialise (CalcInput fun) , Cbor.Serialise (CalcOutput fun) ) => CalculatorFunction (fun :: Function) where diff --git a/grapesy/util/Network/GRPC/Util/Session/Channel.hs b/grapesy/util/Network/GRPC/Util/Session/Channel.hs index fb5afc4..9db22b2 100644 --- a/grapesy/util/Network/GRPC/Util/Session/Channel.hs +++ b/grapesy/util/Network/GRPC/Util/Session/Channel.hs @@ -34,11 +34,13 @@ module Network.GRPC.Util.Session.Channel ( ) where import Control.Concurrent.STM +import Control.DeepSeq (NFData, force) import Control.Exception import Control.Monad import Control.Monad.Catch (ExitCase(..)) import Data.Bifunctor import Data.ByteString.Builder (Builder) +import Data.ByteString.Lazy qualified as BS.Lazy import GHC.Stack -- Doesn't really matter if we import from .Client or .Server @@ -55,7 +57,6 @@ import Network.GRPC.Util.RedundantConstraint import Network.GRPC.Util.Session.API import Network.GRPC.Util.Thread import Network.GRPC.Util.Parser qualified as Parser -import Data.ByteString.Lazy qualified as BS.Lazy {------------------------------------------------------------------------------- Definitions @@ -237,15 +238,19 @@ getInboundHeaders Channel{channelInbound} = -- which 'StreamElem.whenDefinitelyFinal' considers to be final). Doing so will -- result in a 'SendAfterFinal' exception. send :: forall sess. - HasCallStack + (HasCallStack, NFData (Message (Outbound sess))) => Channel sess -> StreamElem (Trailers (Outbound sess)) (Message (Outbound sess)) -> IO () -send Channel{channelOutbound, channelSentFinal} msg = - withThreadInterface channelOutbound aux +send Channel{channelOutbound, channelSentFinal} = \msg -> do + msg' <- evaluate $ force <$> msg + withThreadInterface channelOutbound $ aux msg' where - aux :: FlowState (Outbound sess) -> STM () - aux st = do + aux :: + StreamElem (Trailers (Outbound sess)) (Message (Outbound sess)) + -> FlowState (Outbound sess) + -> STM () + aux msg st = do -- By checking that we haven't sent the final message yet, we know that -- this call to 'putMVar' will not block indefinitely: the thread that -- sends messages to the peer will get to it eventually (unless it dies,