Simpler routes in Servant (#230)

* Add mu-servant-server to Nix

default.nix

@@ -33,5 +33,6 @@ in {
   mu-protobuf = hnPkgs.mu-protobuf.components.library;
   mu-rpc = hnPkgs.mu-rpc.components.library;
   mu-schema = hnPkgs.mu-schema.components.library;
+  mu-servant-server = hnPkgs.mu-servant-server.components.library;
   mu-tracing = hnPkgs.mu-tracing.components.library;
 }

examples/health-check/src/Server.hs

@@ -151,32 +151,25 @@ instance MonadMonitor m => MonadMonitor (TraceT m)
 -- Information for servant
 
 type instance AnnotatedPackage ServantRoute HealthCheckServiceFS2
-  = '[ 'AnnService "HealthCheckServiceFS2" ('ServantRoute '["health"])
-     , 'AnnMethod "HealthCheckServiceFS2" "setStatus"   ('ServantRoute '["status"])
-     , 'AnnMethod "HealthCheckServiceFS2" "check"       ('ServantRoute '["status"])
-     , 'AnnMethod "HealthCheckServiceFS2" "clearStatus" ('ServantRoute '["status"])
-     , 'AnnMethod "HealthCheckServiceFS2" "checkAll"    ('ServantRoute '["all", "status"])
-     , 'AnnMethod "HealthCheckServiceFS2" "cleanAll"    ('ServantRoute '["all", "status"])
-     , 'AnnMethod "HealthCheckServiceFS2" "watch"       ('ServantRoute '["watch"])
+  = '[ 'AnnService "HealthCheckServiceFS2"
+                   ('ServantTopLevelRoute '["health"])
+     , 'AnnMethod "HealthCheckServiceFS2" "setStatus"
+                  ('ServantRoute '["status"] 'POST 200)
+     , 'AnnMethod "HealthCheckServiceFS2" "check"
+                  ('ServantRoute '["status"] 'GET 200)
+     , 'AnnMethod "HealthCheckServiceFS2" "clearStatus"
+                  ('ServantRoute '["status"] 'DELETE 200)
+     , 'AnnMethod "HealthCheckServiceFS2" "checkAll"
+                  ('ServantRoute '["all", "status"] 'GET 200)
+     , 'AnnMethod "HealthCheckServiceFS2" "cleanAll"
+                  ('ServantRoute '["all", "status"] 'DELETE 200)
+     , 'AnnMethod "HealthCheckServiceFS2" "watch"
+                  ('ServantRoute '["watch"] 'GET 200)
      ]
 
-type instance AnnotatedPackage ServantMethod HealthCheckService
-  = '[ 'AnnMethod "HealthCheckServiceFS2" "setStatus"   ('ServantMethod 'POST)
-     , 'AnnMethod "HealthCheckServiceFS2" "check"       ('ServantMethod 'GET)
-     , 'AnnMethod "HealthCheckServiceFS2" "clearStatus" ('ServantMethod 'DELETE)
-     , 'AnnMethod "HealthCheckServiceFS2" "checkAll"    ('ServantMethod 'GET)
-     , 'AnnMethod "HealthCheckServiceFS2" "cleanAll"    ('ServantMethod 'DELETE)
-     , 'AnnMethod "HealthCheckServiceFS2" "watch"       ('ServantMethod 'GET)
+type instance AnnotatedSchema ServantContentTypes HealthCheckSchema
+  = '[ 'AnnType "HealthCheck"  DefaultServantContentTypes
+     , 'AnnType "ServerStatus" DefaultServantContentTypes
+     , 'AnnType "HealthStatus" DefaultServantContentTypes
+     , 'AnnType "AllStatus"    DefaultServantContentTypes
      ]
-
-type instance AnnotatedPackage ServantStatus HealthCheckService = '[]
-
-type instance AnnotatedSchema ServantUnaryContentTypes HealthCheckSchema
-  = '[ 'AnnType "HealthCheck"  ('ServantUnaryContentTypes '[JSON])
-     , 'AnnType "ServerStatus" ('ServantUnaryContentTypes '[JSON])
-     , 'AnnType "HealthStatus" ('ServantUnaryContentTypes '[JSON])
-     , 'AnnType "AllStatus"    ('ServantUnaryContentTypes '[JSON])
-     ]
-
-type instance AnnotatedSchema ServantStreamContentType HealthCheckSchema
-  = '[ 'AnnType "ServerStatus" ('ServantStreamContentType NewlineFraming JSON) ]

servant/server/exe/ExampleServer.hs

@@ -29,30 +29,18 @@ quickstartAPI = packageAPI (quickstartServer @ServerErrorIO)
 
 type instance
   AnnotatedPackage ServantRoute QuickStartService =
-    '[ 'AnnService "Greeter" ('ServantRoute '["greet"]),
-       'AnnMethod "Greeter" "SayHello" ('ServantRoute '["say", "hello"]),
-       'AnnMethod "Greeter" "SayHi" ('ServantRoute '["say", "hi"]),
-       'AnnMethod "Greeter" "SayManyHellos" ('ServantRoute '["say", "many", "hellos"])
+    '[ 'AnnService "Greeter" ('ServantTopLevelRoute '["greet"]),
+       'AnnMethod "Greeter" "SayHello"
+                  ('ServantRoute '["say", "hello"] 'POST 200),
+       'AnnMethod "Greeter" "SayHi"
+                  ('ServantRoute '["say", "hi"] 'POST 200),
+       'AnnMethod "Greeter" "SayManyHellos"
+                  ('ServantRoute '["say", "many", "hellos"] 'POST 200)
      ]
 
 type instance
-  AnnotatedPackage ServantMethod QuickStartService =
-    '[]
-
-type instance
-  AnnotatedPackage ServantStatus QuickStartService =
-    '[]
-
-type instance
-  AnnotatedSchema ServantUnaryContentTypes QuickstartSchema =
-    '[ 'AnnType "HelloRequest" ('ServantUnaryContentTypes '[JSON]),
-       'AnnType "HelloResponse" ('ServantUnaryContentTypes '[JSON]),
-       'AnnType "HiRequest" ('ServantUnaryContentTypes '[JSON])
-     ]
-
-type instance
-  AnnotatedSchema ServantStreamContentType QuickstartSchema =
-    '[ 'AnnType "HelloRequest" ('ServantStreamContentType NewlineFraming JSON),
-       'AnnType "HelloResponse" ('ServantStreamContentType NewlineFraming JSON),
-       'AnnType "HiRequest" ('ServantStreamContentType NewlineFraming JSON)
+  AnnotatedSchema ServantContentTypes QuickstartSchema =
+    '[ 'AnnType "HelloRequest" DefaultServantContentTypes,
+       'AnnType "HelloResponse" DefaultServantContentTypes,
+       'AnnType "HiRequest" DefaultServantContentTypes
      ]

servant/server/mu-servant-server.cabal

@@ -28,6 +28,7 @@ library
     , base
     , conduit
     , generic-aeson
+    , ghc-prim
     , mtl
     , mu-rpc
     , mu-schema

servant/server/src/Mu/Servant/Server.hs

@@ -150,9 +150,8 @@ module Mu.Servant.Server (
   servantServerHandlers,
   packageAPI,
   ServantRoute(..),
-  ServantMethod(..),
-  ServantStatus(..),
-  ServantUnaryContentTypes(..),
+  DefaultServantContentTypes,
+  ServantContentTypes(..),
   ServantStreamContentType(..),
   StreamResult(..),
   toHandler,
@@ -173,6 +172,7 @@ import           Data.Kind
 import           Generics.Generic.Aeson
 import           GHC.Generics
 import           GHC.TypeLits
+import           GHC.Types                 (Any)
 import           Mu.Rpc
 import           Mu.Rpc.Annotations
 import           Mu.Schema
@@ -440,10 +440,13 @@ sourceToSource (SourceT src) = ConduitT (PipeM (liftIO $ src (pure . go)) >>=)
     go (Servant.Types.SourceT.Error msg) =
       PipeM (throwError $ Mu.Server.ServerError Invalid ("error reading stream: " ++ msg))
 
--- | ServantRoute represents the URL path components of a route. It is used as an `AnnotatedPackage` domain to override the default path for a `Method`. When used in an `AnnService`, the specified route is used as a prefix for all `Method`s in that `Service`. When used in an `AnnMethod` the specified route is only applied to that single `Method`.
-newtype ServantRoute = ServantRoute [Symbol]
-
-type family Any :: k
+-- | ServantRoute represents the URL path components of a route. It is used as an `AnnotatedPackage` domain to override the default path for a `Method`. When used in an `AnnService`, the specified `TopLevelRoute` is used as a prefix for all `Method`s in that `Service`.
+-- 1. List of components for the route,
+-- 2. HTTP method which must be used,
+-- 3. HTTP status code of a successful HTTP response from a specific `Method`. Use 200 for the usual status code.
+data ServantRoute
+  = ServantTopLevelRoute [Symbol]
+  | ServantRoute [Symbol] StdMethod Nat
 
 type family Assert (err :: Constraint) (break :: k1) (a :: k2) :: k2 where
   -- these cases exist to force evaluation of the "break" parameter when it either has kind [RpcAnnotation ...] or [Annotation ...]
@@ -487,12 +490,13 @@ type family RouteFor (pkg :: Package snm mnm anm tyref) (s :: Symbol) (m :: Symb
   RouteFor pkg s m =
     WithAnnotatedPackageInstance ServantRoute pkg (
       Concat
-        (UnwrapServantRoute (FromMaybe ('ServantRoute '[s]) (GetServiceAnnotationMay (AnnotatedPackage ServantRoute pkg) s)))
-        (UnwrapServantRoute (FromMaybe ('ServantRoute '[m]) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) s m)))
+        (UnwrapServantRoute (FromMaybe ('ServantRoute '[s] Any Any) (GetServiceAnnotationMay (AnnotatedPackage ServantRoute pkg) s)))
+        (UnwrapServantRoute (FromMaybe ('ServantRoute '[m] Any Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) s m)))
     )
 
 type family UnwrapServantRoute s where
-  UnwrapServantRoute ('ServantRoute s) = s
+  UnwrapServantRoute ('ServantTopLevelRoute s) = s
+  UnwrapServantRoute ('ServantRoute s _ _)     = s
 
 type family FromMaybe (a :: k) (ma :: Maybe k) :: k where
   FromMaybe a 'Nothing = a
@@ -506,68 +510,75 @@ type family PrefixRoute (prefix :: [Symbol]) route where
   PrefixRoute '[] route = route
   PrefixRoute (p ': rest) route = p :> PrefixRoute rest route
 
--- | ServantUnaryContentTypes represents that acceptable content types that can be used when a message in encoded in a unary (non-streaming) HTTP request\/response body. It is used as an `AnnotatedSchema` domain.
-newtype ServantUnaryContentTypes = ServantUnaryContentTypes [Type]
+-- | ServantContentTypes represents that acceptable content types that can be used when a message in encoded:
+-- 1. in a unary (non-streaming) HTTP request\/response body,
+-- 2. encoded in a streaming HTTP request\/response body.
+-- It is used as an `AnnotatedSchema` domain.
+data ServantContentTypes
+  = ServantContentTypes
+      { unary  :: [Type]
+      , stream :: Maybe ServantStreamContentType
+      }
+
+type DefaultServantContentTypes
+  = 'ServantContentTypes '[JSON] ('Just ('ServantStreamContentType NewlineFraming JSON))
 
--- | ServantStreamContentType represents the content type and framing that must be used when a message in encoded in a streaming HTTP request/response body. It is used as an `AnnotatedSchema` domain.
 data ServantStreamContentType
   = ServantStreamContentType
       { framing           :: Type,
         streamContentType :: Type
       }
 
--- | ServantMethod represents the HTTP method which must be used when sending a request to a `Method` handler. It can be used as an `AnnotatedPackage` domain to override the default method of `POST`.
-newtype ServantMethod = ServantMethod StdMethod
-
--- | ServantStatus represents the HTTP status code of a successful HTTP response from a specific `Method`. It can be used as an `AnnotatedPackage` domain to override the default status code of 200.
-newtype ServantStatus = ServantStatus Nat
-
 -- extracts a StdMethod from a ServantMethod annotation of a given method, defaulting to POST if such an annotation doesn't exist
 type family HttpMethodFor pkg sname mname :: StdMethod where
   HttpMethodFor pkg sname mname =
-    WithAnnotatedPackageInstance ServantMethod pkg (
-      UnwrapServantMethod (FromMaybe ('ServantMethod 'POST) (GetMethodAnnotationMay (AnnotatedPackage ServantMethod pkg) sname mname))
+    WithAnnotatedPackageInstance ServantRoute pkg (
+      UnwrapServantMethod (FromMaybe ('ServantRoute Any 'POST Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname))
     )
 
 type family UnwrapServantMethod m where
-  UnwrapServantMethod ('ServantMethod m) = m
+  UnwrapServantMethod ('ServantRoute _ m _) = m
 
 -- extracts the HTTP status code from the ServantStatus annotation of a given method, or defaults to 200 if such an annotation doesn't exist
 type family HttpStatusFor pkg sname mname :: Nat where
   HttpStatusFor pkg sname mname =
-    WithAnnotatedPackageInstance ServantStatus pkg (
-      UnwrapServantStatus (FromMaybe ('ServantStatus 200) (GetMethodAnnotationMay (AnnotatedPackage ServantStatus pkg) sname mname))
+    WithAnnotatedPackageInstance ServantRoute pkg (
+      UnwrapServantStatus (FromMaybe ('ServantRoute Any Any 200) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname))
     )
 
 type family UnwrapServantStatus s where
-  UnwrapServantStatus ('ServantStatus s) = s
+  UnwrapServantStatus ('ServantRoute _ _ s) = s
 
 -- extracts a list of content types from a ServantUnaryContentTypes annotation of a given method
 type family UnaryContentTypesFor (tyRef :: TypeRef sname) :: [Type] where
   UnaryContentTypesFor ('SchemaRef schema typeName) =
-    WithAnnotatedSchemaInstance ServantUnaryContentTypes schema (
-      UnwrapServantUnaryContentType (GetTypeAnnotation (AnnotatedSchema ServantUnaryContentTypes schema) typeName)
+    WithAnnotatedSchemaInstance ServantContentTypes schema (
+      UnwrapServantUnaryContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
     )
 
-type family UnwrapServantUnaryContentType (sctype :: ServantUnaryContentTypes) :: [Type] where
-  UnwrapServantUnaryContentType ('ServantUnaryContentTypes ctype) = ctype
+type family UnwrapServantUnaryContentType (sctype :: ServantContentTypes) :: [Type] where
+  UnwrapServantUnaryContentType ('ServantContentTypes ctype stype) = ctype
 
 -- extracts a content type from a ServantStreamContentType annotation of a given method
 type family StreamContentTypeFor (tyRef :: TypeRef sname) :: Type where
   StreamContentTypeFor ('SchemaRef schema typeName) =
-    WithAnnotatedSchemaInstance ServantStreamContentType schema (
-      StreamContentType (GetTypeAnnotation (AnnotatedSchema ServantStreamContentType schema) typeName)
+    WithAnnotatedSchemaInstance ServantContentTypes schema (
+      StreamContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
     )
 
-type family StreamContentType (sct :: ServantStreamContentType) where
-  StreamContentType ('ServantStreamContentType _ ctype) = ctype
+type family StreamContentType (sct :: ServantContentTypes) where
+  StreamContentType ('ServantContentTypes _ 'Nothing)
+    = TypeError ('Text "missing stream content type")
+  StreamContentType ('ServantContentTypes _ ('Just ('ServantStreamContentType _ ctype))) = ctype
 
 -- extracts a framing from a ServantStreamContentType annotation of a given method
 type family StreamFramingFor (tyRef :: TypeRef sname) :: Type where
   StreamFramingFor ('SchemaRef schema typeName) =
-    WithAnnotatedSchemaInstance ServantStreamContentType schema (
-      StreamFraming (GetTypeAnnotation (AnnotatedSchema ServantStreamContentType schema) typeName)
+    WithAnnotatedSchemaInstance ServantContentTypes schema (
+      StreamFraming (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
     )
 
-type family StreamFraming (sct :: ServantStreamContentType) where
-  StreamFraming ('ServantStreamContentType framing _) = framing
+type family StreamFraming (sct :: ServantContentTypes) where
+  StreamFraming ('ServantContentTypes _ 'Nothing)
+    = TypeError ('Text "missing stream content type")
+  StreamFraming ('ServantContentTypes _ ('Just ('ServantStreamContentType framing _))) = framing