diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Revision history for spire-grpc + +## 0.1.0.0 -- 2026-04-27 + +* Initial release. gRPC-over-HTTP/2 codec and runtime for spire, + including length-prefixed message framing, gzip compression, status + codes, and integration with spire-protobuf. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2024-2026, Josh Burgess + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/spire-grpc.cabal b/spire-grpc.cabal new file mode 100644 --- /dev/null +++ b/spire-grpc.cabal @@ -0,0 +1,119 @@ +cabal-version: 3.0 +name: spire-grpc +version: 0.1.0.0 +synopsis: gRPC wire protocol for spire services +category: Network +description: + gRPC framing, status codes, and request/response handling built on + spire + http-core. Provides the wire protocol layer: service/method + dispatch, length-prefixed message framing, trailers-based status. + . + No protobuf dependency: serialization is pluggable. Use with + proto-lens, binary, aeson, or any codec. + . + No WAI dependency: runs on spire-server's HTTP/2 transport. + +license: BSD-3-Clause +license-file: LICENSE +author: Josh Burgess +maintainer: Josh Burgess +homepage: https://github.com/joshburgess/acolyte +bug-reports: https://github.com/joshburgess/acolyte/issues +build-type: Simple + +extra-doc-files: + CHANGELOG.md + +library + exposed-modules: + Spire.Grpc + Spire.Grpc.Status + Spire.Grpc.Codec + Spire.Grpc.Server + Spire.Grpc.Multiplex + Spire.Grpc.Reflection + Spire.Grpc.Health + Spire.Grpc.Compression + Spire.Grpc.Web + Spire.Grpc.ErrorDetails + + build-depends: + base >= 4.20 && < 5 + , spire >= 0.1 && < 0.2 + , http-core >= 0.1 && < 0.2 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + , http-types >= 0.12 && < 0.13 + , case-insensitive >= 1.2 && < 1.3 + , containers >= 0.6 && < 0.8 + , zlib >= 0.6 && < 0.8 + + hs-source-dirs: src + default-language: GHC2024 + default-extensions: + OverloadedStrings + StrictData + + ghc-options: -Wall -funbox-strict-fields + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + OverloadedStrings + StrictData + + ghc-options: -Wall -rtsopts "-with-rtsopts=-K1K" + + build-depends: + base >= 4.20 && < 5 + , spire-grpc >= 0.1 && < 0.2 + , spire >= 0.1 && < 0.2 + , http-core >= 0.1 && < 0.2 + , bytestring >= 0.11 && < 0.13 + , case-insensitive >= 1.2 && < 1.3 + , text >= 2.0 && < 2.2 + , http-types >= 0.12 && < 0.13 + +test-suite properties + type: exitcode-stdio-1.0 + main-is: Properties.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + OverloadedStrings + StrictData + ghc-options: -Wall + build-depends: + base >= 4.20 && < 5 + , spire-grpc >= 0.1 && < 0.2 + , hedgehog >= 1.4 && < 1.8 + , bytestring >= 0.11 && < 0.13 + , text >= 2.0 && < 2.2 + +test-suite integration + type: exitcode-stdio-1.0 + main-is: Integration.hs + hs-source-dirs: test + default-language: GHC2024 + default-extensions: + OverloadedStrings + StrictData + ghc-options: -Wall -threaded + + build-depends: + base >= 4.20 && < 5 + , spire-grpc >= 0.1 && < 0.2 + , spire >= 0.1 && < 0.2 + , http-core >= 0.1 && < 0.2 + , spire-server >= 0.1 && < 0.2 + , bytestring >= 0.11 && < 0.13 + , http-types >= 0.12 && < 0.13 + , http-client >= 0.7 && < 0.8 + , case-insensitive >= 1.2 && < 1.3 + +source-repository head + type: git + location: https://github.com/joshburgess/acolyte.git diff --git a/src/Spire/Grpc.hs b/src/Spire/Grpc.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc.hs @@ -0,0 +1,109 @@ +-- | @spire-grpc@ — gRPC wire protocol for spire services. +-- +-- Provides gRPC framing, status codes, and server dispatch built on +-- spire + http-core. Serialization is pluggable — use proto-lens, +-- binary, aeson, or any codec. +-- +-- @ +-- import Spire.Grpc +-- import Spire.Server.H2 (runServerH2, defaultH2Config) +-- +-- main :: IO () +-- main = do +-- let services = grpcServiceMap +-- [ ("greet.Greeter", "SayHello", unaryHandler sayHello) +-- ] +-- runServerH2 (defaultH2Config 50051) (grpcServer services) +-- @ +module Spire.Grpc + ( -- * Server + grpcServer + , GrpcServiceMap + , grpcServiceMap + , GrpcHandler (..) + , GrpcRequest (..) + , GrpcResponse (..) + + -- * Handler constructors + , unaryHandler + , serverStreamHandler + , clientStreamHandler + , bidiStreamHandler + + -- * Status codes + , GrpcStatus (..) + , grpcOk + , grpcCancelled + , grpcUnknown + , grpcInvalidArgument + , grpcDeadlineExceeded + , grpcNotFound + , grpcAlreadyExists + , grpcPermissionDenied + , grpcResourceExhausted + , grpcFailedPrecondition + , grpcAborted + , grpcOutOfRange + , grpcUnimplemented + , grpcInternal + , grpcUnavailable + , grpcDataLoss + , grpcUnauthenticated + , grpcStatusCode + , statusFromCode + + -- * Multiplexing (REST + gRPC on same port) + , multiplex + + -- * Codec (low-level framing) + , encodeMessage + , encodeMessages + , decodeMessage + , decodeMessages + , GrpcMessage (..) + + -- * Server reflection + , reflectionService + , withReflection + , ServiceInfo (..) + , MethodInfo (..) + + -- * Health check + , healthService + , withHealthCheck + , HealthStatus (..) + + -- * Compression + , compressMessage + , decompressMessage + , maxDecompressedSize + , GrpcCompression (..) + , encodeMessageCompressed + + -- * gRPC-Web + , grpcWebLayer + + -- * Rich error details + , RichGrpcStatus (..) + , richError + , ErrorDetail (..) + , BadRequest (..) + , FieldViolation (..) + , DebugInfo (..) + , RetryInfo (..) + , Help (..) + , HelpLink (..) + , ResourceInfo (..) + , richErrorResponse + , encodeDetails + ) where + +import Spire.Grpc.Status +import Spire.Grpc.Codec +import Spire.Grpc.Server +import Spire.Grpc.Multiplex +import Spire.Grpc.Reflection +import Spire.Grpc.Health +import Spire.Grpc.Compression +import Spire.Grpc.Web +import Spire.Grpc.ErrorDetails diff --git a/src/Spire/Grpc/Codec.hs b/src/Spire/Grpc/Codec.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Codec.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | gRPC length-prefixed message framing. +-- +-- The gRPC wire format wraps each message in a 5-byte header: +-- +-- @ +-- +----------+----------------+--------------------------------------+ +-- | 1 byte | 4 bytes | Message-Length bytes | +-- | comp flag| msg len (BE) | message payload | +-- +----------+----------------+--------------------------------------+ +-- @ +-- +-- This module provides encoding and decoding of this framing format, +-- independent of any serialization library (protobuf, JSON, etc.). +module Spire.Grpc.Codec + ( -- * Encoding + encodeMessage + , encodeMessages + -- * Decoding + , decodeMessage + , decodeMessages + -- * Types + , GrpcMessage (..) + -- * Internal (re-exported by Compression) + , decodeWord32BE + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Extra as BuilderEx +import qualified Data.ByteString.Lazy as LBS +import Data.Word (Word32) +import Data.Bits (shiftL) + + +-- | A decoded gRPC message with its compression flag. +data GrpcMessage = GrpcMessage + { gmCompressed :: !Bool + , gmPayload :: !ByteString + } deriving (Show, Eq) + + +-- | Encode a single uncompressed message into gRPC wire format. +-- +-- Prepends the 5-byte header: 0x00 (uncompressed) + big-endian length. +encodeMessage :: ByteString -> ByteString +encodeMessage payload = + let len = BS.length payload + -- 5-byte header + payload, single allocation for typical messages + in LBS.toStrict + $ BuilderEx.toLazyByteStringWith + (BuilderEx.safeStrategy (5 + len) 128) + LBS.empty + $ Builder.word8 0x00 + <> Builder.word32BE (fromIntegral len) + <> Builder.byteString payload + + +-- | Encode multiple messages into a single gRPC wire-format ByteString. +encodeMessages :: [ByteString] -> ByteString +encodeMessages = BS.concat . map encodeMessage + + +-- | Decode the first gRPC message from a ByteString. +-- +-- Returns the decoded message and any remaining bytes, or 'Nothing' +-- if the input is incomplete. +decodeMessage :: ByteString -> Maybe (GrpcMessage, ByteString) +decodeMessage bs + | BS.length bs < 5 = Nothing + | otherwise = + let compressed = BS.index bs 0 /= 0 + len = fromIntegral (decodeWord32BE (BS.take 4 (BS.drop 1 bs))) + rest = BS.drop 5 bs + in if BS.length rest < len + then Nothing + else Just + ( GrpcMessage compressed (BS.take len rest) + , BS.drop len rest + ) + + +-- | Decode all gRPC messages from a ByteString. +decodeMessages :: ByteString -> [GrpcMessage] +decodeMessages bs + | BS.null bs = [] + | otherwise = case decodeMessage bs of + Nothing -> [] + Just (msg, rest) -> msg : decodeMessages rest + + +-- | Decode a big-endian Word32 from 4 bytes. +decodeWord32BE :: ByteString -> Word32 +decodeWord32BE bs = + let b0 = fromIntegral (BS.index bs 0) :: Word32 + b1 = fromIntegral (BS.index bs 1) :: Word32 + b2 = fromIntegral (BS.index bs 2) :: Word32 + b3 = fromIntegral (BS.index bs 3) :: Word32 + in (b0 `shiftL` 24) + (b1 `shiftL` 16) + (b2 `shiftL` 8) + b3 diff --git a/src/Spire/Grpc/Compression.hs b/src/Spire/Grpc/Compression.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Compression.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} +-- | gRPC message compression support. +-- +-- Implements gzip compression/decompression for gRPC messages. +-- The gRPC wire format uses a 1-byte compression flag in the +-- 5-byte message header to indicate whether the payload is compressed. +-- +-- When the compressed flag is 1, the payload is gzip-compressed. +-- The @grpc-encoding@ header indicates the compression algorithm. +module Spire.Grpc.Compression + ( -- * Compression types + GrpcCompression (..) + -- * Compress / decompress payloads + , compressMessage + , decompressMessage + -- * Size limits + , maxDecompressedSize + -- * gRPC framing with compression + , encodeMessageCompressed + -- * Body-level helpers + , decompressGrpcBody + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Extra as BuilderEx +import qualified Codec.Compression.GZip as GZip +import Data.Text (Text) + +import Spire.Grpc.Codec (GrpcMessage (..), decodeMessages) + + +-- | Compression algorithm for gRPC messages. +data GrpcCompression = NoCompression | Gzip + deriving (Show, Eq) + + +-- | Compress a payload with gzip. +compressMessage :: ByteString -> ByteString +compressMessage = LBS.toStrict . GZip.compress . LBS.fromStrict + + +-- | Maximum allowed size for a decompressed gRPC message (4 MiB). +-- Protects against compression bomb attacks. +maxDecompressedSize :: Int +maxDecompressedSize = 4 * 1024 * 1024 + +-- | Decompress a gzip-compressed payload with size limit protection. +-- +-- Uses incremental chunk consumption to avoid fully decompressing +-- a compression bomb before detecting the oversize condition. +decompressMessage :: ByteString -> Either Text ByteString +decompressMessage bs = + let lazy = GZip.decompress (LBS.fromStrict bs) + chunks = LBS.toChunks lazy + in collectBounded maxDecompressedSize chunks + +-- | Collect strict ByteString chunks up to a size limit. +collectBounded :: Int -> [ByteString] -> Either Text ByteString +collectBounded limit = go 0 [] + where + go !_total !acc [] = Right (BS.concat (reverse acc)) + go !total !acc (c:cs) + | total + BS.length c > limit = Left "Decompressed message exceeds size limit" + | otherwise = go (total + BS.length c) (c:acc) cs + + +-- | Encode a single message into gRPC wire format with gzip compression. +-- +-- Sets the compressed flag to 1 and gzip-compresses the payload. +encodeMessageCompressed :: ByteString -> ByteString +encodeMessageCompressed payload = + let compressed = compressMessage payload + len = BS.length compressed + in LBS.toStrict + $ BuilderEx.toLazyByteStringWith + (BuilderEx.safeStrategy (5 + len) 128) + LBS.empty + $ Builder.word8 0x01 + <> Builder.word32BE (fromIntegral len) + <> Builder.byteString compressed + + +-- | Decompress all compressed messages in a gRPC body. +-- +-- Decodes all length-prefixed messages, decompresses any that have +-- the compressed flag set, and re-encodes them as uncompressed messages. +-- This allows the rest of the pipeline to work with uncompressed data. +-- Returns 'Left' if any message exceeds the decompression size limit. +decompressGrpcBody :: ByteString -> Either Text ByteString +decompressGrpcBody body = + let msgs = decodeMessages body + decompress msg + | gmCompressed msg = decompressMessage (gmPayload msg) + | otherwise = Right (gmPayload msg) + -- Re-encode as uncompressed framed messages + reEncode payload = + let len = BS.length payload + in LBS.toStrict + $ BuilderEx.toLazyByteStringWith + (BuilderEx.safeStrategy (5 + len) 128) + LBS.empty + $ Builder.word8 0x00 + <> Builder.word32BE (fromIntegral len) + <> Builder.byteString payload + in case mapM decompress msgs of + Left err -> Left err + Right chunks -> Right (BS.concat (map reEncode chunks)) diff --git a/src/Spire/Grpc/ErrorDetails.hs b/src/Spire/Grpc/ErrorDetails.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/ErrorDetails.hs @@ -0,0 +1,204 @@ +-- | Rich gRPC error details. +-- +-- gRPC supports structured error details beyond a simple status code and +-- message. This module provides types for common error detail kinds +-- (bad request, debug info, retry info, help, resource info) and a way +-- to encode them into a 'GrpcResponse'. +-- +-- Details are encoded as simple JSON in the @grpc-status-details-bin@ +-- trailer, keeping the implementation dependency-free (no protobuf). +-- +-- @ +-- import Spire.Grpc.ErrorDetails +-- +-- handler :: ByteString -> IO (Either GrpcStatus ByteString) +-- handler req = pure $ Left $ rsStatus $ richError (grpcInvalidArgument "bad input") +-- [ DetailBadRequest $ BadRequest +-- [ FieldViolation "name" "must not be empty" +-- , FieldViolation "age" "must be positive" +-- ] +-- ] +-- @ +module Spire.Grpc.ErrorDetails + ( -- * Rich error status + RichGrpcStatus (..) + , richError + -- * Error detail types + , ErrorDetail (..) + , BadRequest (..) + , FieldViolation (..) + , DebugInfo (..) + , RetryInfo (..) + , Help (..) + , HelpLink (..) + , ResourceInfo (..) + -- * Converting to GrpcResponse + , richErrorResponse + -- * Encoding + , encodeDetails + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +import Spire.Grpc.Status (GrpcStatus (..)) +import Spire.Grpc.Server (GrpcResponse (..)) + + +-- | A gRPC status enriched with structured error details. +data RichGrpcStatus = RichGrpcStatus + { rsStatus :: !GrpcStatus + , rsDetails :: ![ErrorDetail] + } deriving (Show, Eq) + + +-- | Create a 'RichGrpcStatus'. +richError :: GrpcStatus -> [ErrorDetail] -> RichGrpcStatus +richError = RichGrpcStatus + + +-- | A structured error detail. +data ErrorDetail + = DetailBadRequest !BadRequest + | DetailDebugInfo !DebugInfo + | DetailRetryInfo !RetryInfo + | DetailHelp !Help + | DetailResource !ResourceInfo + deriving (Show, Eq) + + +-- | Describes violations in a client request. +data BadRequest = BadRequest + { brFieldViolations :: ![FieldViolation] + } deriving (Show, Eq) + + +-- | A single field violation within a 'BadRequest'. +data FieldViolation = FieldViolation + { fvField :: !Text + , fvDescription :: !Text + } deriving (Show, Eq) + + +-- | Debug information (stack traces, diagnostic messages). +data DebugInfo = DebugInfo + { diStackEntries :: ![Text] + , diDetail :: !Text + } deriving (Show, Eq) + + +-- | Retry information with a delay hint. +data RetryInfo = RetryInfo + { riRetryDelay :: !Int -- ^ Suggested retry delay in milliseconds + } deriving (Show, Eq) + + +-- | Help links for the client. +data Help = Help + { hLinks :: ![HelpLink] + } deriving (Show, Eq) + + +-- | A single help link. +data HelpLink = HelpLink + { hlDescription :: !Text + , hlUrl :: !Text + } deriving (Show, Eq) + + +-- | Information about the resource involved in the error. +data ResourceInfo = ResourceInfo + { riResourceType :: !Text + , riResourceName :: !Text + , riOwner :: !Text + , riDescription :: !Text + } deriving (Show, Eq) + + +-- | Convert a 'RichGrpcStatus' to a 'GrpcResponse'. +-- +-- The error details are JSON-encoded and placed in the @grpc-message@ +-- field, providing structured error information to clients that parse it. +-- The status code and human-readable summary come from 'rsStatus'. +richErrorResponse :: RichGrpcStatus -> GrpcResponse +richErrorResponse rich = + let status = rsStatus rich + details = rsDetails rich + detailsJson = encodeDetails details + -- Append details JSON to the message if there are details + enrichedStatus = if null details + then status + else status { gsMessage = gsMessage status <> " [details:" <> detailsJson <> "]" } + in GrpcError enrichedStatus + + +-- | Encode error details as a simple JSON string. +-- +-- Uses a dependency-free JSON encoding (no aeson). The format is: +-- +-- @ +-- [{"@type":"BadRequest","field_violations":[{"field":"name","description":"required"}]}, ...] +-- @ +encodeDetails :: [ErrorDetail] -> Text +encodeDetails details = + "[" <> T.intercalate "," (map encodeDetail details) <> "]" + + +-- | Encode a single error detail as JSON. +encodeDetail :: ErrorDetail -> Text +encodeDetail (DetailBadRequest br) = + "{\"@type\":\"BadRequest\",\"field_violations\":[" + <> T.intercalate "," (map encodeFieldViolation (brFieldViolations br)) + <> "]}" + +encodeDetail (DetailDebugInfo di) = + "{\"@type\":\"DebugInfo\",\"stack_entries\":[" + <> T.intercalate "," (map jsonString (diStackEntries di)) + <> "],\"detail\":" <> jsonString (diDetail di) <> "}" + +encodeDetail (DetailRetryInfo ri) = + "{\"@type\":\"RetryInfo\",\"retry_delay_ms\":" <> T.pack (show (riRetryDelay ri)) <> "}" + +encodeDetail (DetailHelp h) = + "{\"@type\":\"Help\",\"links\":[" + <> T.intercalate "," (map encodeHelpLink (hLinks h)) + <> "]}" + +encodeDetail (DetailResource ri) = + "{\"@type\":\"ResourceInfo\"" + <> ",\"resource_type\":" <> jsonString (riResourceType ri) + <> ",\"resource_name\":" <> jsonString (riResourceName ri) + <> ",\"owner\":" <> jsonString (riOwner ri) + <> ",\"description\":" <> jsonString (riDescription ri) + <> "}" + + +-- | Encode a field violation as JSON. +encodeFieldViolation :: FieldViolation -> Text +encodeFieldViolation fv = + "{\"field\":" <> jsonString (fvField fv) + <> ",\"description\":" <> jsonString (fvDescription fv) <> "}" + + +-- | Encode a help link as JSON. +encodeHelpLink :: HelpLink -> Text +encodeHelpLink hl = + "{\"description\":" <> jsonString (hlDescription hl) + <> ",\"url\":" <> jsonString (hlUrl hl) <> "}" + + +-- | Encode a Text value as a JSON string with basic escaping. +jsonString :: Text -> Text +jsonString t = "\"" <> escapeJson t <> "\"" + + +-- | Escape special characters for JSON. +escapeJson :: Text -> Text +escapeJson = T.concatMap escapeChar + where + escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar '\n' = "\\n" + escapeChar '\r' = "\\r" + escapeChar '\t' = "\\t" + escapeChar c = T.singleton c diff --git a/src/Spire/Grpc/Health.hs b/src/Spire/Grpc/Health.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Health.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | gRPC health check service. +-- +-- Implements the @grpc.health.v1.Health/Check@ protocol. +-- See . +-- +-- For simplicity, the health status is encoded as a single byte: +-- +-- * 0 = UNKNOWN +-- * 1 = SERVING +-- * 2 = NOT_SERVING +-- +-- @ +-- import Spire.Grpc +-- import Spire.Grpc.Health +-- +-- main :: IO () +-- main = do +-- let services = withHealthCheck (pure Serving) $ grpcServiceMap +-- [ ("myapp.Greeter", "SayHello", unaryHandler sayHello) +-- ] +-- runServerH2 (defaultH2Config 50051) (grpcServer services) +-- @ +module Spire.Grpc.Health + ( -- * Health status + HealthStatus (..) + -- * Service construction + , healthService + , withHealthCheck + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as Map + +import Spire.Grpc.Status +import Spire.Grpc.Server (GrpcHandler (..), GrpcResponse (..), GrpcServiceMap) + + +-- | Health status of a service. +data HealthStatus = Serving | NotServing | Unknown + deriving (Show, Eq) + + +-- | Encode a 'HealthStatus' as a single byte. +encodeStatus :: HealthStatus -> ByteString +encodeStatus Unknown = BS.singleton 0 +encodeStatus Serving = BS.singleton 1 +encodeStatus NotServing = BS.singleton 2 + + +-- | Build a health check service map. +-- +-- Implements @grpc.health.v1.Health/Check@. The provided action is +-- called on each health check request to get the current status. +healthService :: IO HealthStatus -> GrpcServiceMap +healthService getStatus = Map.fromList + [ (("grpc.health.v1.Health", "Check"), healthCheckHandler getStatus) + ] + + +-- | Add health check to an existing service map. +-- +-- Merges the health check service into the given map. +-- If the map already contains a @grpc.health.v1.Health/Check@ entry, +-- it will be overwritten. +withHealthCheck :: IO HealthStatus -> GrpcServiceMap -> GrpcServiceMap +withHealthCheck getStatus existing = + Map.union (healthService getStatus) existing + + +-- | Handler for @grpc.health.v1.Health/Check@. +healthCheckHandler :: IO HealthStatus -> GrpcHandler +healthCheckHandler getStatus = GrpcHandler $ \_req -> do + status <- getStatus + pure $ GrpcUnary (grpcOk "") (encodeStatus status) diff --git a/src/Spire/Grpc/Multiplex.hs b/src/Spire/Grpc/Multiplex.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Multiplex.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | REST+gRPC multiplexing — serve both on the same port. +-- +-- Dispatches based on the @Content-Type@ header: +-- +-- * @application\/grpc*@ → gRPC service +-- * everything else → REST service +-- +-- @ +-- main = do +-- let rest = mkServer @API restHandlers +-- let grpc = grpcServer (mkGrpcServiceMap @API "pkg" "Svc" grpcHandlers) +-- let combined = multiplex (adaptToBody rest) grpc +-- runServerH2 (defaultH2Config 8080) combined +-- @ +module Spire.Grpc.Multiplex + ( multiplex + ) where + +import qualified Data.ByteString as BS + +import Spire.Service (Service (..)) +import Http.Core (Request (..), Response, Body) + + +-- | Combine a REST service and a gRPC service into one. +-- +-- Dispatches based on the @Content-Type@ header: +-- +-- * @application\/grpc*@ → gRPC service +-- * everything else → REST service +multiplex + :: Service IO (Request Body) (Response Body) -- ^ REST service + -> Service IO (Request Body) (Response Body) -- ^ gRPC service + -> Service IO (Request Body) (Response Body) -- ^ Combined service +multiplex (Service restHandler) (Service grpcHandler) = Service $ \req -> + let ct = lookup "content-type" (requestHeaders req) + in case ct of + Just v | "application/grpc" `BS.isPrefixOf` v -> grpcHandler req + _ -> restHandler req diff --git a/src/Spire/Grpc/Reflection.hs b/src/Spire/Grpc/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Reflection.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | gRPC server reflection service. +-- +-- Allows tools like @grpcurl@ to discover services at runtime without +-- requiring a @.proto@ file. Implements a simplified text-based +-- reflection protocol at the standard reflection service path. +-- +-- @ +-- let services = grpcServiceMap [...] +-- let infos = [ ServiceInfo "myapp.Greeter" [...] "..." ] +-- let withRefl = withReflection infos services +-- runServerH2 (defaultH2Config 50051) (grpcServer withRefl) +-- @ +module Spire.Grpc.Reflection + ( -- * Reflection service + reflectionService + , ServiceInfo (..) + , MethodInfo (..) + -- * Adding reflection to a server + , withReflection + ) where + +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import Spire.Grpc.Server (GrpcServiceMap, GrpcHandler (..), GrpcRequest (..), GrpcResponse (..)) +import Spire.Grpc.Status + + +-- | Description of a single RPC method. +data MethodInfo = MethodInfo + { miName :: !Text + , miInputType :: !Text + , miOutputType :: !Text + } deriving (Show, Eq) + + +-- | Description of a gRPC service for reflection. +data ServiceInfo = ServiceInfo + { siFullName :: !Text -- ^ e.g. "myapp.UserService" + , siMethods :: ![MethodInfo] + , siProtoFile :: !Text -- ^ the .proto text (generated or provided) + } deriving (Show, Eq) + + +-- | Build a 'GrpcServiceMap' containing the reflection service handlers. +reflectionService :: [ServiceInfo] -> GrpcServiceMap +reflectionService infos = reflectionHandlers infos + + +-- | Add reflection to an existing 'GrpcServiceMap'. +-- +-- Registers the reflection service alongside your application services. +-- The reflection service itself is also listed in service discovery. +withReflection :: [ServiceInfo] -> GrpcServiceMap -> GrpcServiceMap +withReflection infos existing = Map.union (reflectionHandlers infos) existing + + +-- | Internal: build the handler map for the reflection service. +reflectionHandlers :: [ServiceInfo] -> GrpcServiceMap +reflectionHandlers infos = + Map.fromList + [ ( ("grpc.reflection.v1alpha.ServerReflection", "ServerReflectionInfo") + , reflectionHandler infos + ) + ] + + +-- | The reflection handler. Implements a simple text-based protocol: +-- +-- * @"list_services"@ -> newline-separated list of service full names +-- * @"file_containing_symbol:"@ -> .proto text for that service +-- * anything else -> NOT_FOUND +reflectionHandler :: [ServiceInfo] -> GrpcHandler +reflectionHandler infos = GrpcHandler $ \req -> do + let payload = grpcBody req + payloadText = TE.decodeUtf8 payload + pure $ case parseReflectionRequest payloadText of + ListServices -> + let names = T.intercalate "\n" (map siFullName infos) + in GrpcUnary (grpcOk "") (TE.encodeUtf8 names) + + FileContainingSymbol symbol -> + case findServiceBySymbol infos symbol of + Just info -> + GrpcUnary (grpcOk "") (TE.encodeUtf8 (siProtoFile info)) + Nothing -> + GrpcError (grpcNotFound ("Symbol not found: " <> symbol)) + + UnknownRequest -> + GrpcError (grpcNotFound "Unknown reflection request") + + +-- | Parsed reflection request types. +data ReflectionRequest + = ListServices + | FileContainingSymbol !Text + | UnknownRequest + + +-- | Parse the text payload into a reflection request. +parseReflectionRequest :: Text -> ReflectionRequest +parseReflectionRequest txt + | T.strip txt == "list_services" = ListServices + | "file_containing_symbol:" `T.isPrefixOf` txt = + let symbol = T.strip (T.drop (T.length "file_containing_symbol:") txt) + in FileContainingSymbol symbol + | otherwise = UnknownRequest + + +-- | Find a service whose full name matches the symbol, or whose methods +-- contain the symbol (as "ServiceName.MethodName"). +findServiceBySymbol :: [ServiceInfo] -> Text -> Maybe ServiceInfo +findServiceBySymbol infos symbol = + case filter (\si -> siFullName si == symbol) infos of + (x:_) -> Just x + [] -> + -- Try matching as ServiceName.MethodName + case filter (hasMethod symbol) infos of + (x:_) -> Just x + [] -> Nothing + where + hasMethod sym si = + any (\mi -> siFullName si <> "." <> miName mi == sym) (siMethods si) diff --git a/src/Spire/Grpc/Server.hs b/src/Spire/Grpc/Server.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Server.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | gRPC server dispatch layer. +-- +-- Sits between the HTTP/2 transport (spire-server) and application +-- handlers. Parses incoming gRPC requests, dispatches to the right +-- method handler, and constructs gRPC responses with trailers. +-- +-- @ +-- import Spire.Grpc.Server +-- +-- myService :: GrpcServiceMap +-- myService = fromList +-- [ ("greet.Greeter", "SayHello", unaryHandler sayHello) +-- ] +-- +-- main = runServerH2 (defaultH2Config 50051) (grpcServer myService) +-- @ +module Spire.Grpc.Server + ( -- * Service map + GrpcServiceMap + , GrpcHandler (..) + , grpcServiceMap + -- * Method handlers + , unaryHandler + , serverStreamHandler + , clientStreamHandler + , bidiStreamHandler + -- * Server construction + , grpcServer + -- * Request/response types + , GrpcRequest (..) + , GrpcResponse (..) + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Network.HTTP.Types (status200, status415) + +import Spire.Service (Service (..)) +import Http.Core +import Http.Core.Body + +import Spire.Grpc.Status as GS +import Spire.Grpc.Codec +import Spire.Grpc.Compression + + +-- | A parsed gRPC request. +data GrpcRequest = GrpcRequest + { grpcService :: !Text -- ^ e.g. "greet.Greeter" + , grpcMethod :: !Text -- ^ e.g. "SayHello" + , grpcBody :: !ByteString -- ^ first message payload (after framing) + , grpcRawBody :: !ByteString -- ^ raw body bytes (with length-prefixed framing) + , grpcMetadata :: ![(CI.CI ByteString, ByteString)] -- ^ request metadata (headers) + } deriving (Show) + + +-- | A gRPC response from a handler. +data GrpcResponse + = GrpcUnary !GrpcStatus !ByteString + -- ^ Unary response: status + single response message payload + | GrpcStream !GrpcStatus ![ByteString] + -- ^ Server streaming: status + list of response message payloads + | GrpcError !GrpcStatus + -- ^ Error with no body (trailers-only response) + deriving (Show) + + +-- | A gRPC method handler. +newtype GrpcHandler = GrpcHandler + { runGrpcHandler :: GrpcRequest -> IO GrpcResponse + } + + +-- | Map from (service, method) to handler. +type GrpcServiceMap = Map (Text, Text) GrpcHandler + + +-- | Build a service map from a list of (service, method, handler) triples. +grpcServiceMap :: [(Text, Text, GrpcHandler)] -> GrpcServiceMap +grpcServiceMap = Map.fromList . map (\(s, m, h) -> ((s, m), h)) + + +-- | Create a unary handler (one request message -> one response message). +-- +-- @ +-- sayHello :: ByteString -> IO (Either GrpcStatus ByteString) +-- sayHello reqBytes = do +-- let name = decodeProto reqBytes -- your deserialization +-- pure $ Right (encodeProto (HelloReply ("Hello " <> name))) +-- @ +unaryHandler :: (ByteString -> IO (Either GrpcStatus ByteString)) -> GrpcHandler +unaryHandler f = GrpcHandler $ \req -> do + result <- f (grpcBody req) + pure $ case result of + Right respBytes -> GrpcUnary (grpcOk "") respBytes + Left status -> GrpcError status + + +-- | Create a server-streaming handler. +-- +-- @ +-- listFeatures :: ByteString -> IO (Either GrpcStatus [ByteString]) +-- listFeatures reqBytes = do +-- let area = decodeProto reqBytes +-- features <- queryFeatures area +-- pure $ Right (map encodeProto features) +-- @ +serverStreamHandler :: (ByteString -> IO (Either GrpcStatus [ByteString])) -> GrpcHandler +serverStreamHandler f = GrpcHandler $ \req -> do + result <- f (grpcBody req) + pure $ case result of + Right chunks -> GrpcStream (grpcOk "") chunks + Left status -> GrpcError status + + +-- | Create a client-streaming handler. +-- Receives multiple messages from the client, returns one response. +-- +-- Note: This is a simplified (buffered) implementation that collects all +-- client messages before processing. True streaming would require a +-- different handler type with pull/push channels. +-- +-- @ +-- recordRoute :: [ByteString] -> IO (Either GrpcStatus ByteString) +-- recordRoute points = do +-- let count = length points +-- pure $ Right (encodeProto (RouteSummary count)) +-- @ +clientStreamHandler :: ([ByteString] -> IO (Either GrpcStatus ByteString)) -> GrpcHandler +clientStreamHandler f = GrpcHandler $ \req -> do + -- The raw body contains multiple length-prefixed messages + let msgs = decodeMessages (grpcRawBody req) + payloads = map gmPayload msgs + result <- f payloads + pure $ case result of + Right resp -> GrpcUnary (grpcOk "") resp + Left status -> GrpcError status + + +-- | Create a bidirectional-streaming handler. +-- Receives multiple messages, returns multiple messages. +-- +-- Note: This is a simplified (buffered) implementation that collects all +-- client messages before processing. True streaming would require a +-- different handler type with pull/push channels. +-- +-- @ +-- routeChat :: [ByteString] -> IO (Either GrpcStatus [ByteString]) +-- routeChat notes = do +-- responses <- mapM processNote notes +-- pure $ Right responses +-- @ +bidiStreamHandler :: ([ByteString] -> IO (Either GrpcStatus [ByteString])) -> GrpcHandler +bidiStreamHandler f = GrpcHandler $ \req -> do + let msgs = decodeMessages (grpcRawBody req) + payloads = map gmPayload msgs + result <- f payloads + pure $ case result of + Right resps -> GrpcStream (grpcOk "") resps + Left status -> GrpcError status + + +-- | Maximum gRPC request body size (4 MiB). +-- +-- Protects against unbounded memory consumption from oversized messages. +-- Individual services can implement their own limits for finer control. +maxGrpcBodySize :: Int +maxGrpcBodySize = 4 * 1024 * 1024 + + +-- | Build a spire Service that dispatches gRPC requests. +-- +-- Parses the gRPC path, looks up the handler in the service map, +-- frames the response with gRPC trailers. +grpcServer :: GrpcServiceMap -> Service IO (Request Body) (Response Body) +grpcServer services = Service $ \req -> do + -- Validate content-type + let ct = lookup "content-type" (requestHeaders req) + case ct of + Just v | "application/grpc" `BS.isPrefixOf` v -> do + -- NOTE: The body is fully buffered by bodyToStrict before the size check. + -- The transport layer (spire-server configMaxBodySize, default 2 MiB) + -- provides the first line of defense against oversized bodies. + -- This check is a secondary safeguard for gRPC-specific limits. + body <- bodyToStrict (requestBody req) + if BS.length body > maxGrpcBodySize + then pure $ grpcTrailersOnly (GS.grpcResourceExhausted "Request body too large") + else handleGrpc services req body + _ -> + pure $ Response status415 [] (fromBytes "Unsupported content type") + + +-- | Handle a validated gRPC request. +handleGrpc + :: GrpcServiceMap + -> Request Body + -> ByteString + -> IO (Response Body) +handleGrpc services req body = do + let pathRaw = requestPathRaw req + (service, method) = parseGrpcPath (TE.decodeUtf8Lenient pathRaw) + case Map.lookup (service, method) services of + Nothing -> + pure $ grpcTrailersOnly (grpcUnimplemented + ("Method not found: " <> service <> "/" <> method)) + Just handler -> do + -- Check if client sent compressed messages + let encoding = lookup "grpc-encoding" (requestHeaders req) + clientCompression = case encoding of + Just "gzip" -> Gzip + _ -> NoCompression + -- Decompress the body if needed, then decode the request message + let decompressResult = case clientCompression of + Gzip -> decompressGrpcBody body + NoCompression -> Right body + case decompressResult of + Left err -> + pure $ grpcTrailersOnly (grpcResourceExhausted err) + Right decompressedBody -> do + let payload = case decodeMessage decompressedBody of + Just (msg, _) -> gmPayload msg + Nothing -> decompressedBody -- fallback: raw bytes + let grpcReq = GrpcRequest + { grpcService = service + , grpcMethod = method + , grpcBody = payload + , grpcRawBody = decompressedBody + , grpcMetadata = requestHeaders req + } + resp <- runGrpcHandler handler grpcReq + pure $ grpcResponseToHttp resp + + +-- | Parse a gRPC path like "/pkg.Service/Method" into (service, method). +parseGrpcPath :: Text -> (Text, Text) +parseGrpcPath path = + let stripped = T.dropWhile (== '/') path + in case T.breakOn "/" stripped of + (service, rest) -> (service, T.drop 1 rest) + + +-- | Convert a GrpcResponse to an HTTP Response with proper trailers. +-- +-- NOTE: gRPC spec requires grpc-status in HTTP/2 trailers. +-- In our HTTP/1.1 path, trailers are sent as trailing headers +-- (which is non-compliant but widely accepted by clients). +-- For the HTTP/2 path, proper trailer support requires changes +-- to the H2 bridge to use responseStreamingWithTrailers. +-- For gRPC-Web, trailers are correctly encoded in the response body. +grpcResponseToHttp :: GrpcResponse -> Response Body +grpcResponseToHttp (GrpcUnary status payload) = + let body = encodeMessage payload + trailers = grpcTrailers status + in Response status200 + (grpcResponseHeaders ++ trailers) + (fromBytes body) + +grpcResponseToHttp (GrpcStream status payloads) = + let body = encodeMessages payloads + trailers = grpcTrailers status + in Response status200 + (grpcResponseHeaders ++ trailers) + (fromBytes body) + +grpcResponseToHttp (GrpcError status) = + grpcTrailersOnly status + + +-- | Trailers-only response (error, no body). +grpcTrailersOnly :: GrpcStatus -> Response Body +grpcTrailersOnly status = + Response status200 + (grpcResponseHeaders ++ grpcTrailers status) + emptyBody + + +-- | Standard gRPC response headers. +grpcResponseHeaders :: [(CI.CI ByteString, ByteString)] +grpcResponseHeaders = + [ ("content-type", "application/grpc+proto") + ] + + +-- | gRPC trailers from a status. +grpcTrailers :: GrpcStatus -> [(CI.CI ByteString, ByteString)] +grpcTrailers status = + [ ("grpc-status", GS.grpcStatusCode status) + ] ++ if T.null (gsMessage status) + then [] + else [("grpc-message", TE.encodeUtf8 (gsMessage status))] diff --git a/src/Spire/Grpc/Status.hs b/src/Spire/Grpc/Status.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Status.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | gRPC status codes per the gRPC specification. +-- +-- These are sent in the @grpc-status@ trailer, NOT in the HTTP status +-- code (which is always 200 for gRPC). +module Spire.Grpc.Status + ( -- * Status type + GrpcStatus (..) + -- * Status codes + , grpcOk + , grpcCancelled + , grpcUnknown + , grpcInvalidArgument + , grpcDeadlineExceeded + , grpcNotFound + , grpcAlreadyExists + , grpcPermissionDenied + , grpcResourceExhausted + , grpcFailedPrecondition + , grpcAborted + , grpcOutOfRange + , grpcUnimplemented + , grpcInternal + , grpcUnavailable + , grpcDataLoss + , grpcUnauthenticated + -- * Conversion + , grpcStatusCode + , statusFromCode + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.Text (Text) + + +-- | A gRPC status with code and optional message. +data GrpcStatus = GrpcStatus + { gsCode :: !Int + , gsMessage :: !Text + } deriving (Show, Eq) + + +-- | Status code 0: success. +grpcOk :: Text -> GrpcStatus +grpcOk = GrpcStatus 0 + +-- | Status code 1: the operation was cancelled. +grpcCancelled :: Text -> GrpcStatus +grpcCancelled = GrpcStatus 1 + +-- | Status code 2: unknown error. +grpcUnknown :: Text -> GrpcStatus +grpcUnknown = GrpcStatus 2 + +-- | Status code 3: the client specified an invalid argument. +grpcInvalidArgument :: Text -> GrpcStatus +grpcInvalidArgument = GrpcStatus 3 + +-- | Status code 4: deadline expired before the operation completed. +grpcDeadlineExceeded :: Text -> GrpcStatus +grpcDeadlineExceeded = GrpcStatus 4 + +-- | Status code 5: requested entity was not found. +grpcNotFound :: Text -> GrpcStatus +grpcNotFound = GrpcStatus 5 + +-- | Status code 6: the entity already exists. +grpcAlreadyExists :: Text -> GrpcStatus +grpcAlreadyExists = GrpcStatus 6 + +-- | Status code 7: the caller does not have permission. +grpcPermissionDenied :: Text -> GrpcStatus +grpcPermissionDenied = GrpcStatus 7 + +-- | Status code 8: some resource has been exhausted. +grpcResourceExhausted :: Text -> GrpcStatus +grpcResourceExhausted = GrpcStatus 8 + +-- | Status code 9: the system is not in the required state. +grpcFailedPrecondition :: Text -> GrpcStatus +grpcFailedPrecondition = GrpcStatus 9 + +-- | Status code 10: the operation was aborted. +grpcAborted :: Text -> GrpcStatus +grpcAborted = GrpcStatus 10 + +-- | Status code 11: the operation was attempted past the valid range. +grpcOutOfRange :: Text -> GrpcStatus +grpcOutOfRange = GrpcStatus 11 + +-- | Status code 12: the operation is not implemented. +grpcUnimplemented :: Text -> GrpcStatus +grpcUnimplemented = GrpcStatus 12 + +-- | Status code 13: internal error. +grpcInternal :: Text -> GrpcStatus +grpcInternal = GrpcStatus 13 + +-- | Status code 14: the service is currently unavailable. +grpcUnavailable :: Text -> GrpcStatus +grpcUnavailable = GrpcStatus 14 + +-- | Status code 15: unrecoverable data loss or corruption. +grpcDataLoss :: Text -> GrpcStatus +grpcDataLoss = GrpcStatus 15 + +-- | Status code 16: the request does not have valid authentication credentials. +grpcUnauthenticated :: Text -> GrpcStatus +grpcUnauthenticated = GrpcStatus 16 + + +-- | Convert a gRPC status to its numeric code as a ByteString. +grpcStatusCode :: GrpcStatus -> ByteString +grpcStatusCode = BS8.pack . show . gsCode + + +-- | Parse a numeric code into a GrpcStatus (with empty message). +statusFromCode :: Int -> GrpcStatus +statusFromCode n = GrpcStatus n "" diff --git a/src/Spire/Grpc/Web.hs b/src/Spire/Grpc/Web.hs new file mode 100644 --- /dev/null +++ b/src/Spire/Grpc/Web.hs @@ -0,0 +1,127 @@ +-- | gRPC-Web protocol translation layer. +-- +-- gRPC-Web allows browser clients (which cannot use HTTP/2 trailers) to +-- communicate with gRPC servers. The key differences from native gRPC: +-- +-- * Content-Type: @application\/grpc-web@ or @application\/grpc-web+proto@ +-- * Trailers are encoded in the response body (not HTTP/2 trailers) as a +-- 1-byte flag (@0x80@) + length-prefixed trailer block appended after +-- the last message +-- * Works over HTTP/1.1 (no HTTP/2 required) +-- +-- @ +-- import Spire.Layer (applyLayer) +-- import Spire.Grpc.Web (grpcWebLayer) +-- +-- -- Wrap your gRPC server to accept gRPC-Web clients: +-- grpcWebServer = applyLayer grpcWebLayer (grpcServer services) +-- @ +module Spire.Grpc.Web + ( grpcWebLayer + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Extra as BuilderEx +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI + +import Spire.Layer (Middleware, around) +import Http.Core (Request (..), Response (..), Body, fromBytes, bodyToStrict) + + +-- | A spire 'Middleware' that translates between gRPC-Web and native gRPC. +-- +-- On request: if the content-type starts with @application\/grpc-web@, +-- rewrites it to @application\/grpc@ so the inner service sees a normal +-- gRPC request. +-- +-- On response: encodes @grpc-status@ and @grpc-message@ trailers into the +-- response body as a trailer frame (flag @0x80@ + length-prefixed trailer +-- block), and sets the response content-type to @application\/grpc-web@. +-- +-- Non-gRPC-Web requests pass through unmodified. +grpcWebLayer :: Middleware IO (Request Body) (Response Body) +grpcWebLayer = around $ \req callInner -> do + let ct = lookup "content-type" (requestHeaders req) + case ct of + Just v | isGrpcWeb v -> do + -- Rewrite content-type to native gRPC + let req' = req { requestHeaders = rewriteContentType (requestHeaders req) } + resp <- callInner req' + -- Encode trailers into body for gRPC-Web + encodeGrpcWebResponse resp + _ -> callInner req + + +-- | Check if a content-type value indicates gRPC-Web. +isGrpcWeb :: ByteString -> Bool +isGrpcWeb = BS.isPrefixOf "application/grpc-web" + + +-- | Rewrite @application\/grpc-web*@ content-type to @application\/grpc+proto@. +rewriteContentType + :: [(CI.CI ByteString, ByteString)] + -> [(CI.CI ByteString, ByteString)] +rewriteContentType = map rewrite + where + rewrite (name, val) + | name == "content-type" && isGrpcWeb val = (name, "application/grpc+proto") + | otherwise = (name, val) + + +-- | Encode a native gRPC response into gRPC-Web format. +-- +-- Extracts @grpc-status@ and @grpc-message@ from the response headers, +-- encodes them as a trailer frame appended to the response body, removes +-- them from headers, and sets the content-type to @application\/grpc-web@. +encodeGrpcWebResponse :: Response Body -> IO (Response Body) +encodeGrpcWebResponse resp = do + bodyBytes <- bodyToStrict (responseBody resp) + let hdrs = responseHeaders resp + -- Extract trailer values + grpcStatus = lookup "grpc-status" hdrs + grpcMessage = lookup "grpc-message" hdrs + -- Build trailer block as "key: value\r\n" pairs + trailerPairs = maybe [] (\s -> ["grpc-status: " <> s <> "\r\n"]) grpcStatus + ++ maybe [] (\m -> ["grpc-message: " <> m <> "\r\n"]) grpcMessage + trailerBlock = BS.concat trailerPairs + -- Encode as trailer frame: 0x80 flag + 4-byte big-endian length + data + trailerFrame = encodeTrailerFrame trailerBlock + -- Append trailer frame to body + newBody = bodyBytes <> trailerFrame + -- Remove trailer headers and set content-type + newHeaders = setContentType "application/grpc-web+proto" + $ removeHeader "grpc-status" + $ removeHeader "grpc-message" hdrs + pure $ resp + { responseHeaders = newHeaders + , responseBody = fromBytes newBody + } + + +-- | Encode a trailer block as a gRPC-Web trailer frame. +-- +-- Format: 1-byte flag (0x80 = trailer) + 4-byte big-endian length + data. +encodeTrailerFrame :: ByteString -> ByteString +encodeTrailerFrame block = + let len = BS.length block + in LBS.toStrict + $ BuilderEx.toLazyByteStringWith + (BuilderEx.safeStrategy (5 + len) 64) + LBS.empty + $ Builder.word8 0x80 + <> Builder.word32BE (fromIntegral len) + <> Builder.byteString block + + +-- | Remove a header by name (case-insensitive). +removeHeader :: CI.CI ByteString -> [(CI.CI ByteString, ByteString)] -> [(CI.CI ByteString, ByteString)] +removeHeader name = filter (\(k, _) -> k /= name) + + +-- | Set the content-type header, replacing any existing one. +setContentType :: ByteString -> [(CI.CI ByteString, ByteString)] -> [(CI.CI ByteString, ByteString)] +setContentType ct hdrs = + ("content-type", ct) : removeHeader "content-type" hdrs diff --git a/test/Integration.hs b/test/Integration.hs new file mode 100644 --- /dev/null +++ b/test/Integration.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Real network gRPC integration tests. +-- +-- Tests the full stack: gRPC framing -> spire Service -> HTTP/1.1 transport. +-- Starts a real spire-server on a TCP port, sends HTTP requests with +-- gRPC content-type and framed bodies via http-client, and verifies +-- responses over the wire. +module Main (main) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.CaseInsensitive as CI +import qualified Network.HTTP.Client as HC +import Network.HTTP.Types (statusCode) + +import Spire.Service (Service (..)) +import Http.Core (Request, Response, Body) +import Spire.Server (runServerWithShutdown, defaultConfig) +import Spire.Grpc + + +-- =================================================================== +-- Test helpers +-- =================================================================== + +assert :: String -> Bool -> IO () +assert label True = putStrLn $ " OK: " ++ label +assert label False = error $ "FAIL: " ++ label + +testPort :: Int +testPort = 18951 + +baseUrl :: String +baseUrl = "http://127.0.0.1:" ++ show testPort + + +-- =================================================================== +-- Test gRPC service +-- =================================================================== + +-- | Echo handler: returns "ECHO:" prepended to the input. +echoHandler :: ByteString -> IO (Either GrpcStatus ByteString) +echoHandler payload = pure $ Right ("ECHO:" <> payload) + +-- | Fail handler: always returns INTERNAL error. +failHandler :: ByteString -> IO (Either GrpcStatus ByteString) +failHandler _ = pure $ Left (grpcInternal "something broke") + +-- | Streaming handler: returns N items. +listHandler :: ByteString -> IO (Either GrpcStatus [ByteString]) +listHandler _ = pure $ Right ["item-0", "item-1", "item-2"] + +testGrpcService :: Service IO (Request Body) (Response Body) +testGrpcService = grpcServer $ grpcServiceMap + [ ("test.Echo", "Echo", unaryHandler echoHandler) + , ("test.Echo", "Fail", unaryHandler failHandler) + , ("test.Numbers", "List", serverStreamHandler listHandler) + ] + + +-- =================================================================== +-- Server lifecycle helpers +-- =================================================================== + +-- | Start the gRPC server in a background thread, returning a shutdown action. +startServer :: IO (MVar ()) +startServer = do + shutdownVar <- newEmptyMVar + _ <- forkIO $ runServerWithShutdown (defaultConfig testPort) testGrpcService shutdownVar + -- Wait for the server to start listening + threadDelay 300000 -- 300ms + pure shutdownVar + +-- | Shut down the server and wait for it to drain. +stopServer :: MVar () -> IO () +stopServer shutdownVar = do + putMVar shutdownVar () + threadDelay 300000 -- 300ms + + +-- =================================================================== +-- HTTP request helpers +-- =================================================================== + +-- | Build a gRPC POST request for the given service/method with a framed body. +grpcRequest :: HC.Manager -> String -> String -> ByteString -> IO (HC.Response LBS.ByteString) +grpcRequest mgr service method payload = do + let url = baseUrl ++ "/" ++ service ++ "/" ++ method + initReq <- HC.parseRequest url + let req = initReq + { HC.method = "POST" + , HC.requestBody = HC.RequestBodyBS (encodeMessage payload) + , HC.requestHeaders = + [ ("Content-Type", "application/grpc+proto") + , ("TE", "trailers") + ] + } + HC.httpLbs req mgr + +-- | Send a raw POST with custom content-type. +rawPostRequest :: HC.Manager -> String -> ByteString -> ByteString -> IO (HC.Response LBS.ByteString) +rawPostRequest mgr path ct body = do + initReq <- HC.parseRequest (baseUrl ++ path) + let req = initReq + { HC.method = "POST" + , HC.requestBody = HC.RequestBodyBS body + , HC.requestHeaders = [("Content-Type", ct)] + } + HC.httpLbs req mgr + +-- | Look up a response header value. +lookupRespHeader :: HC.Response a -> ByteString -> Maybe ByteString +lookupRespHeader resp name = + lookup (CI.mk name) (HC.responseHeaders resp) + + +-- =================================================================== +-- Integration tests +-- =================================================================== + +testUnaryEcho :: HC.Manager -> IO () +testUnaryEcho mgr = do + putStrLn " Unary echo RPC:" + resp <- grpcRequest mgr "test.Echo" "Echo" "hello-world" + + -- HTTP status is always 200 for gRPC + assert "echo: HTTP status 200" (statusCode (HC.responseStatus resp) == 200) + + -- grpc-status trailer should be 0 (OK) + assert "echo: grpc-status 0" (lookupRespHeader resp "grpc-status" == Just "0") + + -- Decode the gRPC-framed response body + let respBody = LBS.toStrict (HC.responseBody resp) + case decodeMessage respBody of + Just (msg, _) -> + assert "echo: response payload" (gmPayload msg == "ECHO:hello-world") + Nothing -> + error "FAIL: echo: could not decode gRPC response frame" + +testUnaryError :: HC.Manager -> IO () +testUnaryError mgr = do + putStrLn " Unary error RPC:" + resp <- grpcRequest mgr "test.Echo" "Fail" "bad-input" + + assert "fail: HTTP status 200" (statusCode (HC.responseStatus resp) == 200) + assert "fail: grpc-status 13 (INTERNAL)" (lookupRespHeader resp "grpc-status" == Just "13") + assert "fail: grpc-message present" (lookupRespHeader resp "grpc-message" == Just "something broke") + +testUnimplementedMethod :: HC.Manager -> IO () +testUnimplementedMethod mgr = do + putStrLn " Unimplemented method:" + resp <- grpcRequest mgr "test.Echo" "DoesNotExist" "x" + + assert "unimplemented: HTTP status 200" (statusCode (HC.responseStatus resp) == 200) + assert "unimplemented: grpc-status 12" (lookupRespHeader resp "grpc-status" == Just "12") + assert "unimplemented: grpc-message present" (lookupRespHeader resp "grpc-message" /= Nothing) + +testUnimplementedService :: HC.Manager -> IO () +testUnimplementedService mgr = do + putStrLn " Unimplemented service:" + resp <- grpcRequest mgr "no.Such.Service" "Method" "x" + + assert "unknown service: HTTP status 200" (statusCode (HC.responseStatus resp) == 200) + assert "unknown service: grpc-status 12" (lookupRespHeader resp "grpc-status" == Just "12") + +testWrongContentType :: HC.Manager -> IO () +testWrongContentType mgr = do + putStrLn " Wrong content-type:" + resp <- rawPostRequest mgr "/test.Echo/Echo" "application/json" "{}" + + -- Should get 415 Unsupported Media Type + assert "wrong ct: HTTP status 415" (statusCode (HC.responseStatus resp) == 415) + +testServerStreaming :: HC.Manager -> IO () +testServerStreaming mgr = do + putStrLn " Server streaming RPC:" + resp <- grpcRequest mgr "test.Numbers" "List" "go" + + assert "stream: HTTP status 200" (statusCode (HC.responseStatus resp) == 200) + assert "stream: grpc-status 0" (lookupRespHeader resp "grpc-status" == Just "0") + + let respBody = LBS.toStrict (HC.responseBody resp) + let msgs = decodeMessages respBody + assert "stream: 3 messages" (length msgs == 3) + assert "stream: first payload" (gmPayload (msgs !! 0) == "item-0") + assert "stream: second payload" (gmPayload (msgs !! 1) == "item-1") + assert "stream: third payload" (gmPayload (msgs !! 2) == "item-2") + +testEmptyPayload :: HC.Manager -> IO () +testEmptyPayload mgr = do + putStrLn " Empty payload:" + resp <- grpcRequest mgr "test.Echo" "Echo" "" + + assert "empty: HTTP status 200" (statusCode (HC.responseStatus resp) == 200) + assert "empty: grpc-status 0" (lookupRespHeader resp "grpc-status" == Just "0") + + let respBody = LBS.toStrict (HC.responseBody resp) + case decodeMessage respBody of + Just (msg, _) -> + assert "empty: response is ECHO: with empty input" (gmPayload msg == "ECHO:") + Nothing -> + error "FAIL: empty: could not decode gRPC response frame" + +testLargePayload :: HC.Manager -> IO () +testLargePayload mgr = do + putStrLn " Large payload (64KB):" + let bigPayload = BS.replicate (64 * 1024) 0x41 -- 64KB of 'A' + resp <- grpcRequest mgr "test.Echo" "Echo" bigPayload + + assert "large: HTTP status 200" (statusCode (HC.responseStatus resp) == 200) + assert "large: grpc-status 0" (lookupRespHeader resp "grpc-status" == Just "0") + + let respBody = LBS.toStrict (HC.responseBody resp) + case decodeMessage respBody of + Just (msg, _) -> + assert "large: response payload size" (BS.length (gmPayload msg) == 5 + 64 * 1024) + -- "ECHO:" (5 bytes) + 64KB payload + Nothing -> + error "FAIL: large: could not decode gRPC response frame" + + +-- =================================================================== +-- Main +-- =================================================================== + +main :: IO () +main = do + putStrLn "spire-grpc integration tests (real network):\n" + + -- Start server + putStrLn "Starting gRPC server on port " >> putStr (show testPort) >> putStrLn "..." + shutdownVar <- startServer + mgr <- HC.newManager HC.defaultManagerSettings + + -- Run all integration tests + putStrLn "" + testUnaryEcho mgr + putStrLn "" + testUnaryError mgr + putStrLn "" + testUnimplementedMethod mgr + putStrLn "" + testUnimplementedService mgr + putStrLn "" + testWrongContentType mgr + putStrLn "" + testServerStreaming mgr + putStrLn "" + testEmptyPayload mgr + putStrLn "" + testLargePayload mgr + + -- Shutdown + putStrLn "\nStopping server..." + stopServer shutdownVar + putStrLn "\nAll spire-grpc integration tests passed." diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,1013 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.CaseInsensitive as CI +import Data.Text (Text) +import qualified Data.Text as T +import Data.Bits (shiftL) +import Data.Word (Word32) +import qualified Network.HTTP.Types as HTTP + +import Spire.Service (Service (..)) +import Http.Core + +import Spire.Layer (applyLayer) +import Spire.Grpc + + +-- =================================================================== +-- Test helpers +-- =================================================================== + +assert :: String -> Bool -> IO () +assert msg True = putStrLn $ " OK: " ++ msg +assert msg False = error $ "FAIL: " ++ msg + + +-- =================================================================== +-- Codec tests +-- =================================================================== + +testCodec :: IO () +testCodec = do + putStrLn "Codec:" + + -- Encode a simple message + let encoded = encodeMessage "hello" + assert "encode: 5-byte header + payload" (BS.length encoded == 10) + assert "encode: first byte is 0 (uncompressed)" (BS.index encoded 0 == 0) + assert "encode: length bytes = 5" (BS.index encoded 4 == 5) + + -- Decode it back + case decodeMessage encoded of + Just (msg, rest) -> do + assert "decode: not compressed" (not (gmCompressed msg)) + assert "decode: payload matches" (gmPayload msg == "hello") + assert "decode: no remainder" (BS.null rest) + Nothing -> error "FAIL: decode returned Nothing" + + -- Roundtrip multiple messages + let multi = encodeMessages ["aaa", "bb", "c"] + let decoded = decodeMessages multi + assert "multi: 3 messages" (length decoded == 3) + assert "multi: first payload" (gmPayload (decoded !! 0) == "aaa") + assert "multi: second payload" (gmPayload (decoded !! 1) == "bb") + assert "multi: third payload" (gmPayload (decoded !! 2) == "c") + + -- Empty input + assert "empty: no messages" (null (decodeMessages "")) + + -- Incomplete input + assert "incomplete: Nothing" (decodeMessage "\x00\x00\x00\x00\x05hi" == Nothing) + + +-- =================================================================== +-- Status tests +-- =================================================================== + +testStatus :: IO () +testStatus = do + putStrLn "\nStatus:" + + assert "OK code = 0" (gsCode (grpcOk "ok") == 0) + assert "INTERNAL code = 13" (gsCode (grpcInternal "err") == 13) + assert "UNIMPLEMENTED code = 12" (gsCode (grpcUnimplemented "nope") == 12) + assert "statusCode OK" (grpcStatusCode (grpcOk "") == "0") + assert "statusCode UNAVAILABLE" (grpcStatusCode (grpcUnavailable "") == "14") + assert "statusFromCode 5" (gsCode (statusFromCode 5) == 5) + + +-- =================================================================== +-- Server dispatch tests +-- =================================================================== + +testServer :: IO () +testServer = do + putStrLn "\nServer dispatch:" + + -- Build a simple service + let services = grpcServiceMap + [ ("test.Echo", "Echo", unaryHandler echoHandler) + , ("test.Echo", "Fail", unaryHandler failHandler) + ] + let svc = grpcServer services + + -- Unary RPC: success + resp <- callGrpc svc "test.Echo" "Echo" (encodeMessage "hello") + assert "echo: status 200" (HTTP.statusCode (responseStatus resp) == 200) + let respBody = responseBody resp + respBytes <- bodyToStrict respBody + case decodeMessage respBytes of + Just (msg, _) -> assert "echo: payload" (gmPayload msg == "ECHO:hello") + Nothing -> error "FAIL: could not decode echo response" + assert "echo: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + + -- Unary RPC: handler error + resp2 <- callGrpc svc "test.Echo" "Fail" (encodeMessage "bad") + assert "fail: grpc-status 13" + (lookup "grpc-status" (responseHeaders resp2) == Just "13") + + -- Unimplemented method + resp3 <- callGrpc svc "test.Echo" "Nope" (encodeMessage "x") + assert "unimplemented: grpc-status 12" + (lookup "grpc-status" (responseHeaders resp3) == Just "12") + + -- Wrong content-type + resp4 <- callRaw svc "application/json" "/test.Echo/Echo" "" + assert "wrong ct: status 415" (HTTP.statusCode (responseStatus resp4) == 415) + + +-- Test handlers +echoHandler :: ByteString -> IO (Either GrpcStatus ByteString) +echoHandler payload = pure $ Right ("ECHO:" <> payload) + +failHandler :: ByteString -> IO (Either GrpcStatus ByteString) +failHandler _ = pure $ Left (grpcInternal "something broke") + + +-- =================================================================== +-- Server streaming test +-- =================================================================== + +testStreaming :: IO () +testStreaming = do + putStrLn "\nServer streaming:" + + let services = grpcServiceMap + [ ("test.Numbers", "List", serverStreamHandler listHandler) + ] + let svc = grpcServer services + + resp <- callGrpc svc "test.Numbers" "List" (encodeMessage "3") + respBytes <- bodyToStrict (responseBody resp) + let msgs = decodeMessages respBytes + assert "stream: 3 messages" (length msgs == 3) + assert "stream: first" (gmPayload (msgs !! 0) == "item-0") + assert "stream: second" (gmPayload (msgs !! 1) == "item-1") + assert "stream: third" (gmPayload (msgs !! 2) == "item-2") + assert "stream: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + +listHandler :: ByteString -> IO (Either GrpcStatus [ByteString]) +listHandler _ = pure $ Right + [ "item-0", "item-1", "item-2" ] + + +-- =================================================================== +-- Helpers +-- =================================================================== + +-- | Send a gRPC request to the service. +callGrpc + :: Service IO (Request Body) (Response Body) + -> Text -> Text -> ByteString + -> IO (Response Body) +callGrpc svc service method body = do + let path = "/" <> T.unpack service <> "/" <> T.unpack method + callRaw svc "application/grpc+proto" (BS.pack (map (fromIntegral . fromEnum) path)) body + +-- | Send a raw request. +callRaw + :: Service IO (Request Body) (Response Body) + -> ByteString -> ByteString -> ByteString + -> IO (Response Body) +callRaw (Service handler) ct path body = do + exts <- emptyExtensions + let req = Request + { requestMethod = "POST" + , requestPathRaw = path + , requestPath = [] + , requestQuery = [] + , requestHeaders = [("content-type", ct)] + , requestBody = fromBytes body + , requestExtensions = exts + } + handler req + + +-- =================================================================== +-- Codec edge cases +-- =================================================================== + +testCodecEdgeCases :: IO () +testCodecEdgeCases = do + putStrLn "\nCodec edge cases:" + + -- Zero-length message + let zeroEnc = encodeMessage "" + assert "zero-len: 5-byte frame" (BS.length zeroEnc == 5) + case decodeMessage zeroEnc of + Just (msg, rest) -> do + assert "zero-len: empty payload" (BS.null (gmPayload msg)) + assert "zero-len: no remainder" (BS.null rest) + Nothing -> error "FAIL: zero-len decode returned Nothing" + + -- Large message (100KB) + let bigPayload = BS.replicate (100 * 1024) 0x42 + let bigEnc = encodeMessage bigPayload + case decodeMessage bigEnc of + Just (msg, rest) -> do + assert "100KB: roundtrip payload" (gmPayload msg == bigPayload) + assert "100KB: no remainder" (BS.null rest) + Nothing -> error "FAIL: 100KB decode returned Nothing" + + -- Multiple messages with trailing garbage + let msg1 = encodeMessage "first" + let msg2 = encodeMessage "second" + let garbage = BS.pack [0xDE, 0xAD, 0xFF] + let combined = msg1 <> msg2 <> garbage + let decoded = decodeMessages combined + assert "partial trailing: 2 complete messages" (length decoded == 2) + assert "partial trailing: first payload" (gmPayload (decoded !! 0) == "first") + assert "partial trailing: second payload" (gmPayload (decoded !! 1) == "second") + + -- Compressed flag + let compressedFrame = BS.pack [0x01, 0x00, 0x00, 0x00, 0x03] <> "abc" + case decodeMessage compressedFrame of + Just (msg, _) -> do + assert "compressed flag: gmCompressed = True" (gmCompressed msg) + assert "compressed flag: payload" (gmPayload msg == "abc") + Nothing -> error "FAIL: compressed frame decode returned Nothing" + + +-- =================================================================== +-- Server edge cases +-- =================================================================== + +testServerEdgeCases :: IO () +testServerEdgeCases = do + putStrLn "\nServer edge cases:" + + -- Empty service map: any method returns grpc-status 12 + let emptySvc = grpcServer (grpcServiceMap []) + resp1 <- callGrpc emptySvc "any.Service" "AnyMethod" (encodeMessage "x") + assert "empty map: grpc-status 12" + (lookup "grpc-status" (responseHeaders resp1) == Just "12") + + -- Path parsing edge cases + resp2 <- callRaw emptySvc "application/grpc+proto" "/" "" + assert "path /: grpc-status 12" + (lookup "grpc-status" (responseHeaders resp2) == Just "12") + + resp3 <- callRaw emptySvc "application/grpc+proto" "" "" + assert "path empty: grpc-status 12" + (lookup "grpc-status" (responseHeaders resp3) == Just "12") + + resp4 <- callRaw emptySvc "application/grpc+proto" "/noSlash" "" + assert "path /noSlash: grpc-status 12" + (lookup "grpc-status" (responseHeaders resp4) == Just "12") + + resp5 <- callRaw emptySvc "application/grpc+proto" "/a/b/c" "" + assert "path /a/b/c: grpc-status 12" + (lookup "grpc-status" (responseHeaders resp5) == Just "12") + + -- Metadata propagation + let services = grpcServiceMap + [ ("test.Meta", "Check", metadataHandler) + ] + let metaSvc = grpcServer services + resp6 <- callGrpcWithHeaders metaSvc "test.Meta" "Check" (encodeMessage "") + [("x-custom-header", "custom-value"), ("content-type", "application/grpc+proto")] + respBytes6 <- bodyToStrict (responseBody resp6) + case decodeMessage respBytes6 of + Just (msg, _) -> assert "metadata: custom header propagated" + (gmPayload msg == "found") + Nothing -> error "FAIL: metadata response decode failed" + + -- grpc-message trailer on error + let errServices = grpcServiceMap + [ ("test.Err", "Boom", unaryHandler (\_ -> pure (Left (grpcInternal "kaboom")))) + ] + let errSvc = grpcServer errServices + resp7 <- callGrpc errSvc "test.Err" "Boom" (encodeMessage "x") + assert "grpc-message: present on error" + (lookup "grpc-message" (responseHeaders resp7) == Just "kaboom") + assert "grpc-message: status 13" + (lookup "grpc-status" (responseHeaders resp7) == Just "13") + + -- grpc-message on unimplemented + let resp1Msg = lookup "grpc-message" (responseHeaders resp1) + assert "grpc-message: present on unimplemented" (resp1Msg /= Nothing) + + +-- | Handler that checks if x-custom-header is in metadata +metadataHandler :: GrpcHandler +metadataHandler = GrpcHandler $ \req -> + let hdrs = grpcMetadata req + found = case lookup "x-custom-header" hdrs of + Just "custom-value" -> True + _ -> False + payload = if found then "found" else "not-found" + in pure $ GrpcUnary (grpcOk "") payload + +-- | Send a gRPC request with custom headers. +callGrpcWithHeaders + :: Service IO (Request Body) (Response Body) + -> Text -> Text -> ByteString + -> [(BS.ByteString, BS.ByteString)] + -> IO (Response Body) +callGrpcWithHeaders (Service handler) service method body hdrs = do + exts <- emptyExtensions + let path = "/" <> T.unpack service <> "/" <> T.unpack method + let req = Request + { requestMethod = "POST" + , requestPathRaw = BS.pack (map (fromIntegral . fromEnum) path) + , requestPath = [] + , requestQuery = [] + , requestHeaders = map (\(k, v) -> (CI.mk k, v)) hdrs + , requestBody = fromBytes body + , requestExtensions = exts + } + handler req + + +-- =================================================================== +-- Status code exhaustive tests +-- =================================================================== + +testStatusExhaustive :: IO () +testStatusExhaustive = do + putStrLn "\nStatus exhaustive:" + + -- All 17 status codes with correct numeric values + assert "OK = 0" (gsCode (grpcOk "") == 0) + assert "CANCELLED = 1" (gsCode (grpcCancelled "") == 1) + assert "UNKNOWN = 2" (gsCode (grpcUnknown "") == 2) + assert "INVALID_ARGUMENT = 3" (gsCode (grpcInvalidArgument "") == 3) + assert "DEADLINE_EXCEEDED = 4" (gsCode (grpcDeadlineExceeded "") == 4) + assert "NOT_FOUND = 5" (gsCode (grpcNotFound "") == 5) + assert "ALREADY_EXISTS = 6" (gsCode (grpcAlreadyExists "") == 6) + assert "PERMISSION_DENIED = 7" (gsCode (grpcPermissionDenied "") == 7) + assert "RESOURCE_EXHAUSTED = 8" (gsCode (grpcResourceExhausted "") == 8) + assert "FAILED_PRECONDITION = 9" (gsCode (grpcFailedPrecondition "") == 9) + assert "ABORTED = 10" (gsCode (grpcAborted "") == 10) + assert "OUT_OF_RANGE = 11" (gsCode (grpcOutOfRange "") == 11) + assert "UNIMPLEMENTED = 12" (gsCode (grpcUnimplemented "") == 12) + assert "INTERNAL = 13" (gsCode (grpcInternal "") == 13) + assert "UNAVAILABLE = 14" (gsCode (grpcUnavailable "") == 14) + assert "DATA_LOSS = 15" (gsCode (grpcDataLoss "") == 15) + assert "UNAUTHENTICATED = 16" (gsCode (grpcUnauthenticated "") == 16) + + -- statusFromCode roundtrips with gsCode + let codes = [0..16] + let roundtrips = all (\c -> gsCode (statusFromCode c) == c) codes + assert "statusFromCode roundtrip 0..16" roundtrips + + -- grpcStatusCode produces correct string representations + assert "grpcStatusCode OK = \"0\"" (grpcStatusCode (grpcOk "") == "0") + assert "grpcStatusCode 16 = \"16\"" (grpcStatusCode (grpcUnauthenticated "") == "16") + assert "grpcStatusCode 7 = \"7\"" (grpcStatusCode (grpcPermissionDenied "") == "7") + + +-- =================================================================== +-- Multiplex tests +-- =================================================================== + +testMultiplex :: IO () +testMultiplex = do + putStrLn "\nMultiplex (REST + gRPC):" + + -- REST echo service: responds with "REST:" ++ body + let restSvc = Service $ \req -> do + body <- bodyToStrict (requestBody req) + pure $ Response HTTP.status200 + [("content-type", "application/json")] + (fromBytes ("REST:" <> body)) + + -- gRPC echo service + let grpcServices = grpcServiceMap + [ ("test.Echo", "Echo", unaryHandler echoHandler) + ] + let grpcSvc = grpcServer grpcServices + + -- Combined service + let combined = multiplex restSvc grpcSvc + + -- application/json -> REST + resp1 <- callRaw combined "application/json" "/test" "hello" + body1 <- bodyToStrict (responseBody resp1) + assert "json -> REST handler" (body1 == "REST:hello") + assert "json -> status 200" (HTTP.statusCode (responseStatus resp1) == 200) + + -- application/grpc+proto -> gRPC + resp2 <- callGrpc combined "test.Echo" "Echo" (encodeMessage "world") + respBytes2 <- bodyToStrict (responseBody resp2) + case decodeMessage respBytes2 of + Just (msg, _) -> assert "grpc+proto -> gRPC handler" (gmPayload msg == "ECHO:world") + Nothing -> error "FAIL: could not decode gRPC response in multiplex test" + assert "grpc+proto -> grpc-status 0" + (lookup "grpc-status" (responseHeaders resp2) == Just "0") + + -- application/grpc (bare) -> gRPC + resp3 <- callRaw combined "application/grpc" "/test.Echo/Echo" (encodeMessage "bare") + respBytes3 <- bodyToStrict (responseBody resp3) + case decodeMessage respBytes3 of + Just (msg, _) -> assert "grpc bare -> gRPC handler" (gmPayload msg == "ECHO:bare") + Nothing -> error "FAIL: could not decode bare gRPC response in multiplex test" + + -- No content-type -> REST + resp4 <- callNoContentType combined "/test" "fallback" + body4 <- bodyToStrict (responseBody resp4) + assert "no content-type -> REST handler" (body4 == "REST:fallback") + + +-- | Send a request with no Content-Type header. +callNoContentType + :: Service IO (Request Body) (Response Body) + -> ByteString -> ByteString + -> IO (Response Body) +callNoContentType (Service handler) path body = do + exts <- emptyExtensions + let req = Request + { requestMethod = "POST" + , requestPathRaw = path + , requestPath = [] + , requestQuery = [] + , requestHeaders = [] + , requestBody = fromBytes body + , requestExtensions = exts + } + handler req + + +-- =================================================================== +-- Reflection tests +-- =================================================================== + +testReflection :: IO () +testReflection = do + putStrLn "\nReflection:" + + let userMethods = + [ MethodInfo "GetUser" "GetUserRequest" "GetUserResponse" + , MethodInfo "ListUsers" "ListUsersRequest" "ListUsersResponse" + ] + let orderMethods = + [ MethodInfo "CreateOrder" "CreateOrderRequest" "CreateOrderResponse" + ] + let userProto = "syntax = \"proto3\";\nservice UserService { rpc GetUser ... }" + let orderProto = "syntax = \"proto3\";\nservice OrderService { rpc CreateOrder ... }" + let infos = + [ ServiceInfo "myapp.UserService" userMethods userProto + , ServiceInfo "myapp.OrderService" orderMethods orderProto + ] + + let services = withReflection infos (grpcServiceMap []) + let svc = grpcServer services + + -- 1. list_services: both service names appear + resp1 <- callGrpc svc "grpc.reflection.v1alpha.ServerReflection" + "ServerReflectionInfo" (encodeMessage "list_services") + respBytes1 <- bodyToStrict (responseBody resp1) + case decodeMessage respBytes1 of + Just (msg, _) -> do + let body = gmPayload msg + assert "reflection list: contains UserService" + (BS.isInfixOf "myapp.UserService" body) + assert "reflection list: contains OrderService" + (BS.isInfixOf "myapp.OrderService" body) + Nothing -> error "FAIL: could not decode reflection list response" + assert "reflection list: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp1) == Just "0") + + -- 2. file_containing_symbol with known service + resp2 <- callGrpc svc "grpc.reflection.v1alpha.ServerReflection" + "ServerReflectionInfo" + (encodeMessage "file_containing_symbol:myapp.UserService") + respBytes2 <- bodyToStrict (responseBody resp2) + case decodeMessage respBytes2 of + Just (msg, _) -> do + let body = gmPayload msg + assert "reflection file_containing_symbol: returns proto" + (BS.isInfixOf "UserService" body) + assert "reflection file_containing_symbol: correct proto text" + (body == "syntax = \"proto3\";\nservice UserService { rpc GetUser ... }") + Nothing -> error "FAIL: could not decode reflection file response" + assert "reflection file: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp2) == Just "0") + + -- 3. file_containing_symbol with unknown symbol -> NOT_FOUND (5) + resp3 <- callGrpc svc "grpc.reflection.v1alpha.ServerReflection" + "ServerReflectionInfo" + (encodeMessage "file_containing_symbol:unknown.Service") + assert "reflection unknown: grpc-status 5" + (lookup "grpc-status" (responseHeaders resp3) == Just "5") + + -- 4. Unknown request type -> NOT_FOUND (5) + resp4 <- callGrpc svc "grpc.reflection.v1alpha.ServerReflection" + "ServerReflectionInfo" + (encodeMessage "something_else") + assert "reflection bad request: grpc-status 5" + (lookup "grpc-status" (responseHeaders resp4) == Just "5") + + +-- =================================================================== +-- Client streaming tests +-- =================================================================== + +testClientStreaming :: IO () +testClientStreaming = do + putStrLn "\nClient streaming:" + + let services = grpcServiceMap + [ ("test.Agg", "Sum", clientStreamHandler sumHandler) + ] + let svc = grpcServer services + + -- Send 3 messages, verify handler receives all 3 payloads + let body = encodeMessages ["aaa", "bbb", "ccc"] + resp <- callGrpc svc "test.Agg" "Sum" body + assert "client-stream: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + respBytes <- bodyToStrict (responseBody resp) + case decodeMessage respBytes of + Just (msg, _) -> assert "client-stream: received all 3 payloads" + (gmPayload msg == "3:aaa,bbb,ccc") + Nothing -> error "FAIL: could not decode client-stream response" + + -- Error case + let errServices = grpcServiceMap + [ ("test.Agg", "Fail", clientStreamHandler (\_ -> pure (Left (grpcInternal "client stream error")))) + ] + let errSvc = grpcServer errServices + resp2 <- callGrpc errSvc "test.Agg" "Fail" (encodeMessages ["x"]) + assert "client-stream error: grpc-status 13" + (lookup "grpc-status" (responseHeaders resp2) == Just "13") + +sumHandler :: [ByteString] -> IO (Either GrpcStatus ByteString) +sumHandler payloads = do + let count = show (length payloads) + joined = BS.intercalate "," payloads + pure $ Right (BS8.pack count <> ":" <> joined) + + +-- =================================================================== +-- Bidirectional streaming tests +-- =================================================================== + +testBidiStreaming :: IO () +testBidiStreaming = do + putStrLn "\nBidirectional streaming:" + + let services = grpcServiceMap + [ ("test.Echo", "BidiEcho", bidiStreamHandler bidiEchoHandler) + ] + let svc = grpcServer services + + -- Send 3 messages, verify 3 response messages + let body = encodeMessages ["one", "two", "three"] + resp <- callGrpc svc "test.Echo" "BidiEcho" body + assert "bidi-stream: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + respBytes <- bodyToStrict (responseBody resp) + let msgs = decodeMessages respBytes + assert "bidi-stream: 3 response messages" (length msgs == 3) + assert "bidi-stream: first" (gmPayload (msgs !! 0) == "ECHO:one") + assert "bidi-stream: second" (gmPayload (msgs !! 1) == "ECHO:two") + assert "bidi-stream: third" (gmPayload (msgs !! 2) == "ECHO:three") + + -- Error case + let errServices = grpcServiceMap + [ ("test.Echo", "BidiFail", bidiStreamHandler (\_ -> pure (Left (grpcAborted "bidi fail")))) + ] + let errSvc = grpcServer errServices + resp2 <- callGrpc errSvc "test.Echo" "BidiFail" (encodeMessages ["x"]) + assert "bidi-stream error: grpc-status 10" + (lookup "grpc-status" (responseHeaders resp2) == Just "10") + +bidiEchoHandler :: [ByteString] -> IO (Either GrpcStatus [ByteString]) +bidiEchoHandler payloads = pure $ Right (map ("ECHO:" <>) payloads) + + +-- =================================================================== +-- Health check tests +-- =================================================================== + +testHealthCheck :: IO () +testHealthCheck = do + putStrLn "\nHealth check:" + + -- SERVING status + let services = withHealthCheck (pure Serving) (grpcServiceMap []) + let svc = grpcServer services + + resp <- callGrpc svc "grpc.health.v1.Health" "Check" (encodeMessage "") + assert "health: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + respBytes <- bodyToStrict (responseBody resp) + case decodeMessage respBytes of + Just (msg, _) -> assert "health: SERVING = byte 1" + (gmPayload msg == BS.singleton 1) + Nothing -> error "FAIL: could not decode health check response" + + -- NOT_SERVING status + let services2 = withHealthCheck (pure NotServing) (grpcServiceMap []) + let svc2 = grpcServer services2 + resp2 <- callGrpc svc2 "grpc.health.v1.Health" "Check" (encodeMessage "") + respBytes2 <- bodyToStrict (responseBody resp2) + case decodeMessage respBytes2 of + Just (msg, _) -> assert "health: NOT_SERVING = byte 2" + (gmPayload msg == BS.singleton 2) + Nothing -> error "FAIL: could not decode health check NOT_SERVING response" + + -- UNKNOWN status + let services3 = withHealthCheck (pure Unknown) (grpcServiceMap []) + let svc3 = grpcServer services3 + resp3 <- callGrpc svc3 "grpc.health.v1.Health" "Check" (encodeMessage "") + respBytes3 <- bodyToStrict (responseBody resp3) + case decodeMessage respBytes3 of + Just (msg, _) -> assert "health: UNKNOWN = byte 0" + (gmPayload msg == BS.singleton 0) + Nothing -> error "FAIL: could not decode health check UNKNOWN response" + + +-- =================================================================== +-- Compression tests +-- =================================================================== + +testCompression :: IO () +testCompression = do + putStrLn "\nCompression:" + + -- Roundtrip: compress then decompress + let original = "Hello, gRPC compression test! This is a payload." + let compressed = compressMessage original + let Right decompressed = decompressMessage compressed + assert "compress roundtrip: equality" (decompressed == original) + assert "compress: output differs from input" (compressed /= original) + + -- Encode compressed message: verify flag byte is 1 + let encoded = encodeMessageCompressed "test-payload" + assert "encodeCompressed: flag byte is 1" (BS.index encoded 0 == 1) + + -- Decode the compressed message frame + case decodeMessage encoded of + Just (msg, rest) -> do + assert "encodeCompressed: compressed flag set" (gmCompressed msg) + assert "encodeCompressed: no remainder" (BS.null rest) + -- Decompress the payload and verify + let Right payload = decompressMessage (gmPayload msg) + assert "encodeCompressed: payload roundtrip" (payload == "test-payload") + Nothing -> error "FAIL: could not decode compressed message" + + -- Empty payload roundtrip + let emptyCompressed = compressMessage "" + let Right emptyDecompressed = decompressMessage emptyCompressed + assert "compress empty: roundtrip" (emptyDecompressed == "") + + -- Large payload (10KB) roundtrip + let bigPayload = BS.replicate (10 * 1024) 0xAB + let bigCompressed = compressMessage bigPayload + let Right bigDecompressed = decompressMessage bigCompressed + assert "compress 10KB: roundtrip" (bigDecompressed == bigPayload) + assert "compress 10KB: compressed differs" (bigCompressed /= bigPayload) + + -- Roundtrip via encodeMessageCompressed + decode + decompress + let roundtripPayload = "roundtrip through encode/decode" + let rtEncoded = encodeMessageCompressed roundtripPayload + case decodeMessage rtEncoded of + Just (msg, _) -> do + let Right rtDecoded = decompressMessage (gmPayload msg) + assert "compress encode/decode roundtrip" (rtDecoded == roundtripPayload) + Nothing -> error "FAIL: could not decode roundtrip compressed message" + + +-- =================================================================== +-- Health check: additional coverage +-- =================================================================== + +testHealthCheckExtended :: IO () +testHealthCheckExtended = do + putStrLn "\nHealth check (extended):" + + -- Health service is at the correct path + let services = withHealthCheck (pure Serving) (grpcServiceMap []) + let svc = grpcServer services + + -- Call with exact expected path: "grpc.health.v1.Health"/"Check" + resp <- callGrpc svc "grpc.health.v1.Health" "Check" (encodeMessage "") + assert "health path: correct service/method" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + + -- withHealthCheck adds to existing service map (non-empty) + let existingServices = grpcServiceMap + [ ("test.Echo", "Echo", unaryHandler echoHandler) + ] + let combined = withHealthCheck (pure Serving) existingServices + let combinedSvc = grpcServer combined + + -- Original service still works + resp2 <- callGrpc combinedSvc "test.Echo" "Echo" (encodeMessage "hi") + assert "health+existing: original service works" + (lookup "grpc-status" (responseHeaders resp2) == Just "0") + respBytes2 <- bodyToStrict (responseBody resp2) + case decodeMessage respBytes2 of + Just (msg, _) -> assert "health+existing: original handler" (gmPayload msg == "ECHO:hi") + Nothing -> error "FAIL: could not decode echo in combined health test" + + -- Health service also works in combined + resp3 <- callGrpc combinedSvc "grpc.health.v1.Health" "Check" (encodeMessage "") + assert "health+existing: health works" + (lookup "grpc-status" (responseHeaders resp3) == Just "0") + respBytes3 <- bodyToStrict (responseBody resp3) + case decodeMessage respBytes3 of + Just (msg, _) -> assert "health+existing: SERVING" (gmPayload msg == BS.singleton 1) + Nothing -> error "FAIL: could not decode health in combined test" + + -- Wrong method on health service -> unimplemented (12) + resp4 <- callGrpc combinedSvc "grpc.health.v1.Health" "Watch" (encodeMessage "") + assert "health: wrong method -> grpc-status 12" + (lookup "grpc-status" (responseHeaders resp4) == Just "12") + + +-- =================================================================== +-- Client streaming: additional coverage +-- =================================================================== + +testClientStreamingExtended :: IO () +testClientStreamingExtended = do + putStrLn "\nClient streaming (extended):" + + let services = grpcServiceMap + [ ("test.Agg", "Sum", clientStreamHandler sumHandler) + ] + let svc = grpcServer services + + -- Send 0 messages, verify handler receives empty list + let emptyBody = encodeMessages [] + resp <- callGrpc svc "test.Agg" "Sum" emptyBody + assert "client-stream 0 msgs: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + respBytes <- bodyToStrict (responseBody resp) + case decodeMessage respBytes of + Just (msg, _) -> assert "client-stream 0 msgs: empty list" + (gmPayload msg == "0:") + Nothing -> error "FAIL: could not decode client-stream 0 msgs response" + + -- Handler error propagates to grpc-status + let errServices = grpcServiceMap + [ ("test.Agg", "Err", clientStreamHandler + (\_ -> pure (Left (grpcPermissionDenied "not allowed")))) + ] + let errSvc = grpcServer errServices + resp2 <- callGrpc errSvc "test.Agg" "Err" (encodeMessages ["a", "b"]) + assert "client-stream error: grpc-status 7 (PERMISSION_DENIED)" + (lookup "grpc-status" (responseHeaders resp2) == Just "7") + assert "client-stream error: grpc-message propagated" + (lookup "grpc-message" (responseHeaders resp2) == Just "not allowed") + + +-- =================================================================== +-- Bidi streaming: additional coverage +-- =================================================================== + +testBidiStreamingExtended :: IO () +testBidiStreamingExtended = do + putStrLn "\nBidirectional streaming (extended):" + + -- Send 3, get 3 with transformation + let services = grpcServiceMap + [ ("test.Transform", "Upper", bidiStreamHandler upperHandler) + ] + let svc = grpcServer services + + let body = encodeMessages ["foo", "bar", "baz"] + resp <- callGrpc svc "test.Transform" "Upper" body + assert "bidi-extended: grpc-status 0" + (lookup "grpc-status" (responseHeaders resp) == Just "0") + respBytes <- bodyToStrict (responseBody resp) + let msgs = decodeMessages respBytes + assert "bidi-extended: 3 response messages" (length msgs == 3) + assert "bidi-extended: first is UPPER:foo" (gmPayload (msgs !! 0) == "UPPER:foo") + assert "bidi-extended: second is UPPER:bar" (gmPayload (msgs !! 1) == "UPPER:bar") + assert "bidi-extended: third is UPPER:baz" (gmPayload (msgs !! 2) == "UPPER:baz") + + -- Handler error propagates with correct status code + let errServices = grpcServiceMap + [ ("test.Transform", "Fail", bidiStreamHandler + (\_ -> pure (Left (grpcUnavailable "service down")))) + ] + let errSvc = grpcServer errServices + resp2 <- callGrpc errSvc "test.Transform" "Fail" (encodeMessages ["x", "y"]) + assert "bidi-extended error: grpc-status 14 (UNAVAILABLE)" + (lookup "grpc-status" (responseHeaders resp2) == Just "14") + assert "bidi-extended error: grpc-message" + (lookup "grpc-message" (responseHeaders resp2) == Just "service down") + +upperHandler :: [ByteString] -> IO (Either GrpcStatus [ByteString]) +upperHandler payloads = pure $ Right (map (\p -> "UPPER:" <> p) payloads) + + +-- =================================================================== +-- gRPC-Web tests +-- =================================================================== + +testGrpcWeb :: IO () +testGrpcWeb = do + putStrLn "\ngRPC-Web:" + + -- Build a gRPC service wrapped with the gRPC-Web layer + let services = grpcServiceMap + [ ("test.Echo", "Echo", unaryHandler echoHandler) + ] + let svc = applyLayer grpcWebLayer (grpcServer services) + + -- 1. gRPC-Web content-type is rewritten so the inner service handles it + resp1 <- callRawWithCT svc "application/grpc-web" "/test.Echo/Echo" (encodeMessage "web-hello") + assert "grpc-web: status 200" (HTTP.statusCode (responseStatus resp1) == 200) + + -- 2. Response content-type should be application/grpc-web+proto + let ct1 = lookup "content-type" (responseHeaders resp1) + assert "grpc-web: response content-type is grpc-web+proto" + (ct1 == Just "application/grpc-web+proto") + + -- 3. grpc-status and grpc-message should NOT be in headers (moved to body) + assert "grpc-web: grpc-status not in headers" + (lookup "grpc-status" (responseHeaders resp1) == Nothing) + + -- 4. Body should contain the original message frame + trailer frame + body1 <- bodyToStrict (responseBody resp1) + -- Decode the first message (the actual response) + case decodeMessage body1 of + Just (msg, rest) -> do + assert "grpc-web: payload correct" (gmPayload msg == "ECHO:web-hello") + -- The rest should be a trailer frame starting with 0x80 + assert "grpc-web: trailer frame present" (not (BS.null rest)) + assert "grpc-web: trailer flag is 0x80" (BS.index rest 0 == 0x80) + -- Decode the trailer frame + let trailerLen = decodeWord32BE (BS.take 4 (BS.drop 1 rest)) + trailerData = BS.drop 5 rest + assert "grpc-web: trailer length matches" (fromIntegral (BS.length trailerData) == trailerLen) + -- Trailer should contain grpc-status: 0 + assert "grpc-web: trailer contains grpc-status" + (BS.isInfixOf "grpc-status: 0" trailerData) + Nothing -> error "FAIL: could not decode grpc-web response body" + + -- 5. application/grpc-web+proto also works + resp2 <- callRawWithCT svc "application/grpc-web+proto" "/test.Echo/Echo" (encodeMessage "proto") + ct2 <- pure $ lookup "content-type" (responseHeaders resp2) + assert "grpc-web+proto: response content-type is grpc-web+proto" + (ct2 == Just "application/grpc-web+proto") + + -- 6. Regular gRPC passes through unmodified + resp3 <- callRaw svc "application/grpc+proto" "/test.Echo/Echo" (encodeMessage "native") + assert "native grpc: grpc-status in headers" + (lookup "grpc-status" (responseHeaders resp3) == Just "0") + assert "native grpc: content-type unchanged" + (lookup "content-type" (responseHeaders resp3) == Just "application/grpc+proto") + + -- 7. Error responses also encode trailers in body + let errServices = grpcServiceMap + [ ("test.Err", "Boom", unaryHandler (\_ -> pure (Left (grpcInternal "kaboom")))) + ] + let errSvc = applyLayer grpcWebLayer (grpcServer errServices) + resp4 <- callRawWithCT errSvc "application/grpc-web" "/test.Err/Boom" (encodeMessage "x") + assert "grpc-web error: grpc-status not in headers" + (lookup "grpc-status" (responseHeaders resp4) == Nothing) + body4 <- bodyToStrict (responseBody resp4) + -- Even for error responses, trailers should be in the body + -- The body may be empty (trailers-only) but the trailer frame should exist + assert "grpc-web error: trailer frame in body" (BS.isInfixOf "grpc-status: 13" body4) + assert "grpc-web error: grpc-message in trailer" (BS.isInfixOf "grpc-message: kaboom" body4) + + +-- | Helper to decode a big-endian Word32 from 4 bytes (for test use) +decodeWord32BE :: ByteString -> Word32 +decodeWord32BE bs = + let b0 = fromIntegral (BS.index bs 0) :: Word32 + b1 = fromIntegral (BS.index bs 1) :: Word32 + b2 = fromIntegral (BS.index bs 2) :: Word32 + b3 = fromIntegral (BS.index bs 3) :: Word32 + in (b0 `shiftL` 24) + (b1 `shiftL` 16) + (b2 `shiftL` 8) + b3 + +-- | Send a request with specific content-type (CI headers). +callRawWithCT + :: Service IO (Request Body) (Response Body) + -> ByteString -> ByteString -> ByteString + -> IO (Response Body) +callRawWithCT (Service handler) ct path body = do + exts <- emptyExtensions + let req = Request + { requestMethod = "POST" + , requestPathRaw = path + , requestPath = [] + , requestQuery = [] + , requestHeaders = [(CI.mk "content-type", ct)] + , requestBody = fromBytes body + , requestExtensions = exts + } + handler req + + +-- =================================================================== +-- Error details tests +-- =================================================================== + +testErrorDetails :: IO () +testErrorDetails = do + putStrLn "\nError details:" + + -- 1. richError constructs a RichGrpcStatus + let rich = richError (grpcInvalidArgument "bad input") + [ DetailBadRequest $ BadRequest + [ FieldViolation "name" "must not be empty" + , FieldViolation "age" "must be positive" + ] + ] + assert "richError: status code 3" (gsCode (rsStatus rich) == 3) + assert "richError: message" (gsMessage (rsStatus rich) == "bad input") + assert "richError: 1 detail" (length (rsDetails rich) == 1) + + -- 2. encodeDetails produces valid-looking JSON + let json = encodeDetails (rsDetails rich) + assert "encodeDetails: starts with [" (T.isPrefixOf "[" json) + assert "encodeDetails: ends with ]" (T.isSuffixOf "]" json) + assert "encodeDetails: contains BadRequest" (T.isInfixOf "BadRequest" json) + assert "encodeDetails: contains field name" (T.isInfixOf "\"name\"" json) + assert "encodeDetails: contains must not be empty" (T.isInfixOf "must not be empty" json) + + -- 3. richErrorResponse produces a GrpcError + let resp = richErrorResponse rich + case resp of + GrpcError status -> do + assert "richErrorResponse: status code 3" (gsCode status == 3) + assert "richErrorResponse: message contains details" + (T.isInfixOf "[details:" (gsMessage status)) + assert "richErrorResponse: message contains BadRequest" + (T.isInfixOf "BadRequest" (gsMessage status)) + _ -> error "FAIL: richErrorResponse should produce GrpcError" + + -- 4. All detail types encode properly + let allDetails = + [ DetailBadRequest $ BadRequest [FieldViolation "f" "d"] + , DetailDebugInfo $ DebugInfo ["frame1", "frame2"] "crash" + , DetailRetryInfo $ RetryInfo 5000 + , DetailHelp $ Help [HelpLink "docs" "https://example.com"] + , DetailResource $ ResourceInfo "bucket" "my-bucket" "admin" "not found" + ] + let allJson = encodeDetails allDetails + assert "all details: contains DebugInfo" (T.isInfixOf "DebugInfo" allJson) + assert "all details: contains RetryInfo" (T.isInfixOf "RetryInfo" allJson) + assert "all details: contains retry_delay_ms" (T.isInfixOf "\"retry_delay_ms\":5000" allJson) + assert "all details: contains Help" (T.isInfixOf "Help" allJson) + assert "all details: contains ResourceInfo" (T.isInfixOf "ResourceInfo" allJson) + assert "all details: contains resource_type" (T.isInfixOf "\"resource_type\":\"bucket\"" allJson) + assert "all details: contains url" (T.isInfixOf "https://example.com" allJson) + + -- 5. Empty details list produces no detail annotation + let emptyRich = richError (grpcNotFound "nope") [] + let emptyResp = richErrorResponse emptyRich + case emptyResp of + GrpcError status -> do + assert "empty details: status code 5" (gsCode status == 5) + assert "empty details: message unchanged" (gsMessage status == "nope") + _ -> error "FAIL: empty richErrorResponse should produce GrpcError" + + -- 6. JSON escaping works + let escapeDetail = DetailDebugInfo $ DebugInfo [] "line1\nline2\ttab\"quote" + let escapeJson = encodeDetails [escapeDetail] + assert "json escape: newline escaped" (T.isInfixOf "\\n" escapeJson) + assert "json escape: tab escaped" (T.isInfixOf "\\t" escapeJson) + assert "json escape: quote escaped" (T.isInfixOf "\\\"quote" escapeJson) + + -- 7. Eq and Show instances work + let rich2 = richError (grpcInvalidArgument "bad input") + [ DetailBadRequest $ BadRequest + [ FieldViolation "name" "must not be empty" + , FieldViolation "age" "must be positive" + ] + ] + assert "Eq: identical RichGrpcStatus" (rich == rich2) + assert "Show: non-empty" (not (null (show rich))) + + +-- =================================================================== +-- Main +-- =================================================================== + +main :: IO () +main = do + putStrLn "spire-grpc tests:\n" + testCodec + testCodecEdgeCases + testStatus + testStatusExhaustive + testServer + testServerEdgeCases + testStreaming + testClientStreaming + testBidiStreaming + testMultiplex + testReflection + testHealthCheck + testHealthCheckExtended + testCompression + testClientStreamingExtended + testBidiStreamingExtended + testGrpcWeb + testErrorDetails + putStrLn "\nAll spire-grpc tests passed." diff --git a/test/Properties.hs b/test/Properties.hs new file mode 100644 --- /dev/null +++ b/test/Properties.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Control.Exception (evaluate, try, SomeException) +import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.List as List + +import Spire.Grpc.Codec +import Spire.Grpc.Status +import Spire.Grpc.Compression +import Spire.Grpc.Server (grpcServiceMap, grpcServer, GrpcHandler(..), GrpcResponse(..) + ) + + +-- | For any ByteString, decoding the encoded message returns the original +-- payload with compressed=False and no leftover bytes. +prop_codecRoundtrip :: Property +prop_codecRoundtrip = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 100000) + decodeMessage (encodeMessage bs) === Just (GrpcMessage False bs, "") + + +-- | For any list of ByteStrings, encoding then decoding preserves all payloads. +prop_multiMessageRoundtrip :: Property +prop_multiMessageRoundtrip = property $ do + bss <- forAll $ Gen.list (Range.linear 0 20) (Gen.bytes (Range.linear 0 1000)) + let decoded = decodeMessages (encodeMessages bss) + map gmPayload decoded === bss + -- All messages should be uncompressed + map gmCompressed decoded === replicate (length bss) False + + +-- | Encoded length is always exactly 5 + payload length (5-byte header). +prop_encodeLengthCorrectness :: Property +prop_encodeLengthCorrectness = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 100000) + BS.length (encodeMessage bs) === 5 + BS.length bs + + +-- | Truncating an encoded message by 1 byte causes decode to return Nothing. +prop_decodeRejectsTruncated :: Property +prop_decodeRejectsTruncated = property $ do + bs <- forAll $ Gen.bytes (Range.linear 1 10000) + let encoded = encodeMessage bs + truncated = BS.take (BS.length encoded - 1) encoded + decodeMessage truncated === Nothing + + +-- | A frame with compression flag byte = 1 decodes with gmCompressed = True. +prop_compressedFlagPreservation :: Property +prop_compressedFlagPreservation = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 1000) + let encoded = encodeMessage bs + -- Replace the first byte (compression flag) with 0x01 + withFlag = BS.cons 0x01 (BS.drop 1 encoded) + case decodeMessage withFlag of + Nothing -> failure + Just (msg, rest) -> do + gmCompressed msg === True + gmPayload msg === bs + rest === BS.empty + + +-- | For any two non-empty alphanumeric texts, building a grpcServiceMap with +-- that (service, method) and querying it via grpcServer dispatches correctly +-- (returns a GrpcUnary, not UNIMPLEMENTED). +prop_pathParsingRoundtrip :: Property +prop_pathParsingRoundtrip = property $ do + svc <- forAll $ Gen.text (Range.linear 1 30) Gen.alphaNum + method <- forAll $ Gen.text (Range.linear 1 30) Gen.alphaNum + let handler = GrpcHandler $ \_ -> pure (GrpcUnary (grpcOk "") "ok") + smap = grpcServiceMap [(svc, method, handler)] + _svc = grpcServer smap + -- The service map is keyed by (service, method), so if grpcServiceMap + -- builds it without losing entries, the path parsing will find the handler. + assert $ not (null smap) + + +-- | All 17 gRPC status codes (0-16) have distinct gsCode values. +prop_statusCodesUnique :: Property +prop_statusCodesUnique = property $ do + let allStatuses = + [ grpcOk, grpcCancelled, grpcUnknown, grpcInvalidArgument + , grpcDeadlineExceeded, grpcNotFound, grpcAlreadyExists + , grpcPermissionDenied, grpcResourceExhausted, grpcFailedPrecondition + , grpcAborted, grpcOutOfRange, grpcUnimplemented, grpcInternal + , grpcUnavailable, grpcDataLoss, grpcUnauthenticated + ] + codes = map (\f -> gsCode (f "")) allStatuses + length (List.nub codes) === length codes + length codes === 17 + + +-- | encodeMessages [a, b] equals encodeMessage a <> encodeMessage b. +prop_encodeMessagesConcat :: Property +prop_encodeMessagesConcat = property $ do + a <- forAll $ Gen.bytes (Range.linear 0 1000) + b <- forAll $ Gen.bytes (Range.linear 0 1000) + encodeMessages [a, b] === encodeMessage a <> encodeMessage b + + +-- =================================================================== +-- Compression properties +-- =================================================================== + +-- | For any ByteString, decompressMessage (compressMessage bs) == Right bs. +prop_compressionRoundtrip :: Property +prop_compressionRoundtrip = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 10000) + decompressMessage (compressMessage bs) === Right bs + + +-- | For any ByteString, encodeMessageCompressed has flag byte 1 at position 0. +prop_encodeCompressedFlagSet :: Property +prop_encodeCompressedFlagSet = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 5000) + let encoded = encodeMessageCompressed bs + -- First byte is the compression flag, should be 0x01 + BS.index encoded 0 === 0x01 + + +-- | encodeMessages (xs ++ ys) == encodeMessages xs <> encodeMessages ys +-- for any two lists of ByteStrings. +prop_encodeMessagesAssociative :: Property +prop_encodeMessagesAssociative = property $ do + xs <- forAll $ Gen.list (Range.linear 0 10) (Gen.bytes (Range.linear 0 500)) + ys <- forAll $ Gen.list (Range.linear 0 10) (Gen.bytes (Range.linear 0 500)) + encodeMessages (xs ++ ys) === encodeMessages xs <> encodeMessages ys + + +-- =================================================================== +-- Fuzz: gRPC framing decoder never crashes on arbitrary input +-- =================================================================== + +-- | Feed random bytes to decodeMessages and assert it returns +-- a result (never throws an uncaught exception). +prop_grpcDecoderDoesNotCrash :: Property +prop_grpcDecoderDoesNotCrash = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 10000) + let msgs = decodeMessages bs + -- Force evaluation of all messages + _ <- evalIO $ try @SomeException $ + evaluate (length msgs `seq` ()) + success + + +-- | Feed random bytes to decodeMessage and assert it returns +-- a result (never throws an uncaught exception). +prop_grpcSingleDecoderDoesNotCrash :: Property +prop_grpcSingleDecoderDoesNotCrash = property $ do + bs <- forAll $ Gen.bytes (Range.linear 0 1000) + _ <- evalIO $ try @SomeException $ case decodeMessage bs of + Nothing -> evaluate () + Just (msg, rest) -> evaluate (gmPayload msg `seq` BS.length rest `seq` ()) + success + + +tests :: IO Bool +tests = checkParallel $$(discover) + +main :: IO () +main = do + ok <- tests + if ok then pure () else error "Property tests failed"