Merge pull request #245 from well-typed/edsko/documentation-grpc-spec

Improve docs of grpc-spec

.github/workflows/haskell-ci.yml

@@ -219,6 +219,18 @@ jobs:
             benchmarks:  True
             flags:       +build-demo +build-stress-test 
             ghc-options: -Werror
+
+          package quickstart
+            ghc-options: -Werror
+
+          package basics
+            ghc-options: -Werror
+
+          package lowlevel
+            ghc-options: -Werror
+
+          package metadata
+            ghc-options: -Werror
           EOF
           $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(basics|grapesy|grpc-spec|lowlevel|metadata|quickstart)$/; }' >> cabal.project.local
           cat cabal.project

cabal.project.ci

@@ -17,6 +17,18 @@ package grapesy
   flags: +build-demo +build-stress-test 
   ghc-options: -Werror
 
+package quickstart
+  ghc-options: -Werror
+
+package basics
+  ghc-options: -Werror
+
+package lowlevel
+  ghc-options: -Werror
+
+package metadata
+  ghc-options: -Werror
+
 --
 -- ghc 9.10
 --

grapesy/src/Network/GRPC/Common.hs

@@ -32,7 +32,6 @@ module Network.GRPC.Common (
   , ResponseInitialMetadata
   , ResponseTrailingMetadata
   , ResponseMetadata(..)
-  , RawMetadata(..)
     -- ** Serialization
   , BuildMetadata(..)
   , ParseMetadata(..)

grapesy/src/Network/GRPC/Server/Call.hs

@@ -268,9 +268,13 @@ startOutbound serverParams metadataVar kickoffVar cOut = do
         , responseHeaders =
             case start of
               Session.FlowStartRegular headers ->
-                buildResponseHeaders (Proxy @rpc) (outHeaders headers)
+                buildResponseHeaders
+                  (Proxy @rpc)
+                  (outHeaders headers)
               Session.FlowStartNoMessages trailers ->
-                buildTrailersOnly (Proxy @rpc) trailers
+                buildTrailersOnly
+                  (Just . chooseContentType (Proxy @rpc))
+                  trailers
         , responseBody = Nothing
         }
 

grapesy/src/Network/GRPC/Server/RequestHandler.hs

@@ -86,11 +86,8 @@ findHandler handlers req = do
     let path = resourcePath resourceHeaders
     handler <- do
       case HandlerMap.lookup path handlers of
-        Just h  ->
-          return h
-        Nothing -> do
-          let unknown = Proxy @(UnknownRpc Nothing Nothing)
-          throwM $ CallSetupUnimplementedMethod unknown path
+        Just h  -> return h
+        Nothing -> throwM $ CallSetupUnimplementedMethod path
 
     return handler
   where
@@ -153,12 +150,18 @@ failureResponse (CallSetupInvalidRequestHeaders invalid) =
 failureResponse (CallSetupUnsupportedCompression cid) =
     HTTP2.responseBuilder HTTP.badRequest400 [] . Builder.byteString $
       "Unsupported compression: " <> BS.UTF8.fromString (show cid)
-failureResponse (CallSetupUnimplementedMethod proxy path) =
-    HTTP2.responseNoBody HTTP.ok200 . buildTrailersOnly proxy $
+failureResponse (CallSetupUnimplementedMethod path) =
+    HTTP2.responseNoBody HTTP.ok200 . buildTrailersOnly chooseContentType' $
       properTrailersToTrailersOnly (
           grpcExceptionToTrailers $ grpcUnimplemented path
         , Just ContentTypeDefault
         )
+  where
+    -- We cannot use the regular 'chooseContentType' here because we don't know
+    -- which @rpc@ this is (given that it's an unimplemented method).
+    chooseContentType' :: ContentType -> Maybe BS.UTF8.ByteString
+    chooseContentType' ContentTypeDefault       = Nothing
+    chooseContentType' (ContentTypeOverride ct) = Just ct
 
 grpcUnimplemented :: Path -> GrpcException
 grpcUnimplemented path = GrpcException {

grapesy/src/Network/GRPC/Server/Session.hs

@@ -97,7 +97,7 @@ data CallSetupFailure =
     -- has the concept of a "method" (a method, or gRPC call, supported by a
     -- particular service); it's these methods that
     -- 'CallSetupUnimplementedMethod' is referring to.
-  | forall rpc. IsRPC rpc => CallSetupUnimplementedMethod (Proxy rpc) Path
+  | CallSetupUnimplementedMethod Path
 
 deriving stock    instance Show      CallSetupFailure
 deriving anyclass instance Exception CallSetupFailure

grpc-spec/grpc-spec.cabal

@@ -107,7 +107,6 @@ library
       Network.GRPC.Spec.RPC.Protobuf
       Network.GRPC.Spec.RPC.Raw
       Network.GRPC.Spec.RPC.StreamType
-      Network.GRPC.Spec.RPC.Unknown
       Network.GRPC.Spec.Serialization.Base64
       Network.GRPC.Spec.Serialization.CustomMetadata
       Network.GRPC.Spec.Serialization.Headers.Common

grpc-spec/src/Network/GRPC/Spec.hs

@@ -23,10 +23,10 @@ module Network.GRPC.Spec (
   , JsonObject(..)
   , Required(..)
   , Optional(..)
+  , DecodeFields -- opaque
+  , EncodeFields -- opaque
     -- *** Raw
   , RawRpc
-    -- *** Unknown
-  , UnknownRpc
     -- * Streaming types
   , StreamingType(..)
   , SStreamingType(..)
@@ -131,7 +131,6 @@ module Network.GRPC.Spec (
   , ResponseInitialMetadata
   , ResponseTrailingMetadata
   , ResponseMetadata(..)
-  , RawMetadata(..)
     -- ** Serialization
   , BuildMetadata(..)
   , ParseMetadata(..)
@@ -159,7 +158,9 @@ module Network.GRPC.Spec (
   , statusInvalidHeaders
     -- * Common infrastructure to all headers
   , ContentType(..)
+  , chooseContentType
   , MessageType(..)
+  , chooseMessageType
     -- * OpenTelemetry
   , TraceContext(..)
   , TraceId(..)
@@ -187,7 +188,6 @@ import Network.GRPC.Spec.RPC.JSON
 import Network.GRPC.Spec.RPC.Protobuf
 import Network.GRPC.Spec.RPC.Raw
 import Network.GRPC.Spec.RPC.StreamType
-import Network.GRPC.Spec.RPC.Unknown
 import Network.GRPC.Spec.Status
 import Network.GRPC.Spec.Timeout
 import Network.GRPC.Spec.TraceContext

grpc-spec/src/Network/GRPC/Spec/CustomMetadata/Typed.hs

@@ -9,17 +9,13 @@ module Network.GRPC.Spec.CustomMetadata.Typed (
   , StaticMetadata(..)
   , ParseMetadata(..)
   , buildMetadataIO
-    -- * Escape hatch: raw metadata
-  , RawMetadata(..)
   ) where
 
 import Control.DeepSeq (force)
 import Control.Exception
 import Control.Monad.Catch
 import Data.Kind
 import Data.Proxy
-import Data.String
-import GHC.TypeLits
 
 import Network.GRPC.Spec.CustomMetadata.Raw
 
@@ -117,38 +113,3 @@ class BuildMetadata a => StaticMetadata a where
 class ParseMetadata a where
   parseMetadata :: MonadThrow m => [CustomMetadata] -> m a
 
-{-------------------------------------------------------------------------------
-  Clients that want access to all raw, unparsed, custom metadata
--------------------------------------------------------------------------------}
-
--- | Raw metadata
---
--- This can be used with 'OverrideMetadata' to provide essentially an untyped
--- interface to custom metadata, and get access to the raw metadata without
--- any serialization.
-newtype RawMetadata (md :: [Symbol]) = RawMetadata {
-      getRawMetadata :: [CustomMetadata]
-    }
-  deriving stock (Show, Eq)
-
-instance BuildMetadata (RawMetadata md) where
-  buildMetadata = getRawMetadata
-
-instance KnownSymbols md => StaticMetadata (RawMetadata md) where
-  metadataHeaderNames _ = map fromString (symbolVals (Proxy @md))
-
-instance ParseMetadata (RawMetadata md) where
-  parseMetadata = return . RawMetadata
-
-{-------------------------------------------------------------------------------
-  Auxiliary: extend 'KnownSymbol' to a list of symbols
--------------------------------------------------------------------------------}
-
-class KnownSymbols (ns :: [Symbol]) where
-  symbolVals :: Proxy ns -> [String]
-
-instance KnownSymbols '[] where
-  symbolVals _ = []
-
-instance (KnownSymbol n, KnownSymbols ns) => KnownSymbols (n:ns) where
-  symbolVals _ = symbolVal (Proxy @n) : symbolVals (Proxy @ns)

grpc-spec/src/Network/GRPC/Spec/Headers/Common.hs

@@ -13,15 +13,21 @@
 --
 -- Intended for unqualified import.
 module Network.GRPC.Spec.Headers.Common (
-    -- * Definition
+    -- * Content type
     ContentType(..)
+  , chooseContentType
+    -- * Message type
   , MessageType(..)
+  , chooseMessageType
   ) where
 
 import Data.ByteString qualified as Strict (ByteString)
 import Data.Default.Class
+import Data.Proxy
 import GHC.Generics (Generic)
 
+import Network.GRPC.Spec.RPC
+
 {-------------------------------------------------------------------------------
   ContentType
 -------------------------------------------------------------------------------}
@@ -47,6 +53,10 @@ data ContentType =
 instance Default ContentType where
   def = ContentTypeDefault
 
+chooseContentType :: IsRPC rpc => Proxy rpc -> ContentType -> Strict.ByteString
+chooseContentType p ContentTypeDefault       = rpcContentType p
+chooseContentType _ (ContentTypeOverride ct) = ct
+
 {-------------------------------------------------------------------------------
   MessageType
 -------------------------------------------------------------------------------}
@@ -67,3 +77,8 @@ data MessageType =
 instance Default MessageType where
   def = MessageTypeDefault
 
+chooseMessageType ::
+     IsRPC rpc
+  => Proxy rpc -> MessageType -> Maybe Strict.ByteString
+chooseMessageType p MessageTypeDefault       = rpcMessageType p
+chooseMessageType _ (MessageTypeOverride mt) = Just mt

grpc-spec/src/Network/GRPC/Spec/RPC/JSON.hs

@@ -7,6 +7,8 @@ module Network.GRPC.Spec.RPC.JSON (
   , JsonObject(..)
   , Required(..)
   , Optional(..)
+  , DecodeFields -- opaque
+  , EncodeFields -- opaque
   ) where
 
 import Control.DeepSeq (NFData(..))
@@ -159,8 +161,12 @@ newtype Optional a = Optional {
 
 infixr 5 :*
 
+-- | Auxiliary class used for the 'ToJSON' instance for 'JsonObject'
+--
+-- It is not possible (nor necessary) to define additional instances.
 class EncodeFields fs where
   encodeFields :: JsonObject fs -> [Aeson.Pair]
+  encodeFields = undefined
 
 instance EncodeFields '[] where
   encodeFields JsonObject = []
@@ -181,8 +187,12 @@ instance (KnownSymbol f, ToJSON x, EncodeFields fs)
 instance EncodeFields fs => ToJSON (JsonObject fs) where
   toJSON = Aeson.object . encodeFields
 
+-- | Auxiliary class used for the 'FromJSON' instance for 'JsonObject'
+--
+-- It is not possible (nor necessary) to define additional instances.
 class DecodeFields fs where
   decodeFields :: Aeson.Object -> Aeson.Parser (JsonObject fs)
+  decodeFields = undefined
 
 instance DecodeFields '[] where
   decodeFields _ = return JsonObject