spire-grpc (empty) → 0.1.0.0

raw patch · 16 files changed

+2907/−0 lines, 16 filesdep +basedep +bytestringdep +case-insensitive

Dependencies added: base, bytestring, case-insensitive, containers, hedgehog, http-client, http-core, http-types, spire, spire-grpc, spire-server, text, zlib

Files

• CHANGELOG.md +7/−0
• LICENSE +27/−0
• spire-grpc.cabal +119/−0
• src/Spire/Grpc.hs +109/−0
• src/Spire/Grpc/Codec.hs +100/−0
• src/Spire/Grpc/Compression.hs +111/−0
• src/Spire/Grpc/ErrorDetails.hs +204/−0
• src/Spire/Grpc/Health.hs +76/−0
• src/Spire/Grpc/Multiplex.hs +40/−0
• src/Spire/Grpc/Reflection.hs +126/−0
• src/Spire/Grpc/Server.hs +298/−0
• src/Spire/Grpc/Status.hs +120/−0
• src/Spire/Grpc/Web.hs +127/−0
• test/Integration.hs +259/−0
• test/Main.hs +1013/−0
• test/Properties.hs +171/−0

@@ -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.

@@ -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.

@@ -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 <joshburgess.webdev@gmail.com>+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

@@ -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

@@ -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

@@ -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))

@@ -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

@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+-- | gRPC health check service.+--+-- Implements the @grpc.health.v1.Health/Check@ protocol.+-- See <https://github.com/grpc/grpc/blob/master/doc/health-checking.md>.+--+-- 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)

@@ -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

@@ -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:<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)

@@ -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))]

@@ -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 ""

@@ -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

@@ -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."

@@ -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."

@@ -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"