From a7b2e2e4bd4ce0cbaacccbfe09b63cc7dc4b7547 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 28 Sep 2020 12:36:18 +0200 Subject: [PATCH] Simpler routes in Servant (#230) * Add mu-servant-server to Nix --- default.nix | 1 + examples/health-check/src/Server.hs | 45 ++++++------- servant/server/exe/ExampleServer.hs | 34 ++++------ servant/server/mu-servant-server.cabal | 1 + servant/server/src/Mu/Servant/Server.hs | 85 ++++++++++++++----------- 5 files changed, 80 insertions(+), 86 deletions(-) diff --git a/default.nix b/default.nix index 54012a1..9f6ca1f 100644 --- a/default.nix +++ b/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; } diff --git a/examples/health-check/src/Server.hs b/examples/health-check/src/Server.hs index 11e9f6e..b5dcf30 100644 --- a/examples/health-check/src/Server.hs +++ b/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) ] diff --git a/servant/server/exe/ExampleServer.hs b/servant/server/exe/ExampleServer.hs index 93ffdb3..714bb48 100644 --- a/servant/server/exe/ExampleServer.hs +++ b/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 ] diff --git a/servant/server/mu-servant-server.cabal b/servant/server/mu-servant-server.cabal index 50e936a..7773d7c 100644 --- a/servant/server/mu-servant-server.cabal +++ b/servant/server/mu-servant-server.cabal @@ -28,6 +28,7 @@ library , base , conduit , generic-aeson + , ghc-prim , mtl , mu-rpc , mu-schema diff --git a/servant/server/src/Mu/Servant/Server.hs b/servant/server/src/Mu/Servant/Server.hs index 2a0a412..aef93c3 100644 --- a/servant/server/src/Mu/Servant/Server.hs +++ b/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