Skip to content
This repository was archived by the owner on Oct 19, 2024. It is now read-only.

Commit a7b2e2e

Browse files
serrasserras
authored
Simpler routes in Servant (#230)
* Add mu-servant-server to Nix
1 parent 1274e95 commit a7b2e2e

File tree

5 files changed

+80
-86
lines changed

5 files changed

+80
-86
lines changed

‎default.nix

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,5 +33,6 @@ in {
3333
mu-protobuf = hnPkgs.mu-protobuf.components.library;
3434
mu-rpc = hnPkgs.mu-rpc.components.library;
3535
mu-schema = hnPkgs.mu-schema.components.library;
36+
mu-servant-server = hnPkgs.mu-servant-server.components.library;
3637
mu-tracing = hnPkgs.mu-tracing.components.library;
3738
}

‎examples/health-check/src/Server.hs

Lines changed: 19 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -151,32 +151,25 @@ instance MonadMonitor m => MonadMonitor (TraceT m)
151151
-- Information for servant
152152

153153
type instance AnnotatedPackage ServantRoute HealthCheckServiceFS2
154-
= '[ 'AnnService "HealthCheckServiceFS2" ('ServantRoute '["health"])
155-
, 'AnnMethod "HealthCheckServiceFS2" "setStatus" ('ServantRoute '["status"])
156-
, 'AnnMethod "HealthCheckServiceFS2" "check" ('ServantRoute '["status"])
157-
, 'AnnMethod "HealthCheckServiceFS2" "clearStatus" ('ServantRoute '["status"])
158-
, 'AnnMethod "HealthCheckServiceFS2" "checkAll" ('ServantRoute '["all", "status"])
159-
, 'AnnMethod "HealthCheckServiceFS2" "cleanAll" ('ServantRoute '["all", "status"])
160-
, 'AnnMethod "HealthCheckServiceFS2" "watch" ('ServantRoute '["watch"])
154+
= '[ 'AnnService "HealthCheckServiceFS2"
155+
('ServantTopLevelRoute '["health"])
156+
, 'AnnMethod "HealthCheckServiceFS2" "setStatus"
157+
('ServantRoute '["status"] 'POST 200)
158+
, 'AnnMethod "HealthCheckServiceFS2" "check"
159+
('ServantRoute '["status"] 'GET 200)
160+
, 'AnnMethod "HealthCheckServiceFS2" "clearStatus"
161+
('ServantRoute '["status"] 'DELETE 200)
162+
, 'AnnMethod "HealthCheckServiceFS2" "checkAll"
163+
('ServantRoute '["all", "status"] 'GET 200)
164+
, 'AnnMethod "HealthCheckServiceFS2" "cleanAll"
165+
('ServantRoute '["all", "status"] 'DELETE 200)
166+
, 'AnnMethod "HealthCheckServiceFS2" "watch"
167+
('ServantRoute '["watch"] 'GET 200)
161168
]
162169

163-
type instance AnnotatedPackage ServantMethod HealthCheckService
164-
= '[ 'AnnMethod "HealthCheckServiceFS2" "setStatus" ('ServantMethod 'POST)
165-
, 'AnnMethod "HealthCheckServiceFS2" "check" ('ServantMethod 'GET)
166-
, 'AnnMethod "HealthCheckServiceFS2" "clearStatus" ('ServantMethod 'DELETE)
167-
, 'AnnMethod "HealthCheckServiceFS2" "checkAll" ('ServantMethod 'GET)
168-
, 'AnnMethod "HealthCheckServiceFS2" "cleanAll" ('ServantMethod 'DELETE)
169-
, 'AnnMethod "HealthCheckServiceFS2" "watch" ('ServantMethod 'GET)
170+
type instance AnnotatedSchema ServantContentTypes HealthCheckSchema
171+
= '[ 'AnnType "HealthCheck" DefaultServantContentTypes
172+
, 'AnnType "ServerStatus" DefaultServantContentTypes
173+
, 'AnnType "HealthStatus" DefaultServantContentTypes
174+
, 'AnnType "AllStatus" DefaultServantContentTypes
170175
]
171-
172-
type instance AnnotatedPackage ServantStatus HealthCheckService = '[]
173-
174-
type instance AnnotatedSchema ServantUnaryContentTypes HealthCheckSchema
175-
= '[ 'AnnType "HealthCheck" ('ServantUnaryContentTypes '[JSON])
176-
, 'AnnType "ServerStatus" ('ServantUnaryContentTypes '[JSON])
177-
, 'AnnType "HealthStatus" ('ServantUnaryContentTypes '[JSON])
178-
, 'AnnType "AllStatus" ('ServantUnaryContentTypes '[JSON])
179-
]
180-
181-
type instance AnnotatedSchema ServantStreamContentType HealthCheckSchema
182-
= '[ 'AnnType "ServerStatus" ('ServantStreamContentType NewlineFraming JSON) ]

‎servant/server/exe/ExampleServer.hs

Lines changed: 11 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -29,30 +29,18 @@ quickstartAPI = packageAPI (quickstartServer @ServerErrorIO)
2929

3030
type instance
3131
AnnotatedPackage ServantRoute QuickStartService =
32-
'[ 'AnnService "Greeter" ('ServantRoute '["greet"]),
33-
'AnnMethod "Greeter" "SayHello" ('ServantRoute '["say", "hello"]),
34-
'AnnMethod "Greeter" "SayHi" ('ServantRoute '["say", "hi"]),
35-
'AnnMethod "Greeter" "SayManyHellos" ('ServantRoute '["say", "many", "hellos"])
32+
'[ 'AnnService "Greeter" ('ServantTopLevelRoute '["greet"]),
33+
'AnnMethod "Greeter" "SayHello"
34+
('ServantRoute '["say", "hello"] 'POST 200),
35+
'AnnMethod "Greeter" "SayHi"
36+
('ServantRoute '["say", "hi"] 'POST 200),
37+
'AnnMethod "Greeter" "SayManyHellos"
38+
('ServantRoute '["say", "many", "hellos"] 'POST 200)
3639
]
3740

3841
type instance
39-
AnnotatedPackage ServantMethod QuickStartService =
40-
'[]
41-
42-
type instance
43-
AnnotatedPackage ServantStatus QuickStartService =
44-
'[]
45-
46-
type instance
47-
AnnotatedSchema ServantUnaryContentTypes QuickstartSchema =
48-
'[ 'AnnType "HelloRequest" ('ServantUnaryContentTypes '[JSON]),
49-
'AnnType "HelloResponse" ('ServantUnaryContentTypes '[JSON]),
50-
'AnnType "HiRequest" ('ServantUnaryContentTypes '[JSON])
51-
]
52-
53-
type instance
54-
AnnotatedSchema ServantStreamContentType QuickstartSchema =
55-
'[ 'AnnType "HelloRequest" ('ServantStreamContentType NewlineFraming JSON),
56-
'AnnType "HelloResponse" ('ServantStreamContentType NewlineFraming JSON),
57-
'AnnType "HiRequest" ('ServantStreamContentType NewlineFraming JSON)
42+
AnnotatedSchema ServantContentTypes QuickstartSchema =
43+
'[ 'AnnType "HelloRequest" DefaultServantContentTypes,
44+
'AnnType "HelloResponse" DefaultServantContentTypes,
45+
'AnnType "HiRequest" DefaultServantContentTypes
5846
]

‎servant/server/mu-servant-server.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ library
2828
, base
2929
, conduit
3030
, generic-aeson
31+
, ghc-prim
3132
, mtl
3233
, mu-rpc
3334
, mu-schema

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

Lines changed: 48 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -150,9 +150,8 @@ module Mu.Servant.Server (
150150
servantServerHandlers,
151151
packageAPI,
152152
ServantRoute(..),
153-
ServantMethod(..),
154-
ServantStatus(..),
155-
ServantUnaryContentTypes(..),
153+
DefaultServantContentTypes,
154+
ServantContentTypes(..),
156155
ServantStreamContentType(..),
157156
StreamResult(..),
158157
toHandler,
@@ -173,6 +172,7 @@ import Data.Kind
173172
import Generics.Generic.Aeson
174173
import GHC.Generics
175174
import GHC.TypeLits
175+
import GHC.Types (Any)
176176
import Mu.Rpc
177177
import Mu.Rpc.Annotations
178178
import Mu.Schema
@@ -440,10 +440,13 @@ sourceToSource (SourceT src) = ConduitT (PipeM (liftIO $ src (pure . go)) >>=)
440440
go (Servant.Types.SourceT.Error msg) =
441441
PipeM (throwError $ Mu.Server.ServerError Invalid ("error reading stream: " ++ msg))
442442

443-
-- | 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`.
444-
newtype ServantRoute = ServantRoute [Symbol]
445-
446-
type family Any :: k
443+
-- | 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`.
444+
-- 1. List of components for the route,
445+
-- 2. HTTP method which must be used,
446+
-- 3. HTTP status code of a successful HTTP response from a specific `Method`. Use 200 for the usual status code.
447+
data ServantRoute
448+
= ServantTopLevelRoute [Symbol]
449+
| ServantRoute [Symbol] StdMethod Nat
447450

448451
type family Assert (err :: Constraint) (break :: k1) (a :: k2) :: k2 where
449452
-- 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
487490
RouteFor pkg s m =
488491
WithAnnotatedPackageInstance ServantRoute pkg (
489492
Concat
490-
(UnwrapServantRoute (FromMaybe ('ServantRoute '[s]) (GetServiceAnnotationMay (AnnotatedPackage ServantRoute pkg) s)))
491-
(UnwrapServantRoute (FromMaybe ('ServantRoute '[m]) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) s m)))
493+
(UnwrapServantRoute (FromMaybe ('ServantRoute '[s] Any Any) (GetServiceAnnotationMay (AnnotatedPackage ServantRoute pkg) s)))
494+
(UnwrapServantRoute (FromMaybe ('ServantRoute '[m] Any Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) s m)))
492495
)
493496

494497
type family UnwrapServantRoute s where
495-
UnwrapServantRoute ('ServantRoute s) = s
498+
UnwrapServantRoute ('ServantTopLevelRoute s) = s
499+
UnwrapServantRoute ('ServantRoute s _ _) = s
496500

497501
type family FromMaybe (a :: k) (ma :: Maybe k) :: k where
498502
FromMaybe a 'Nothing = a
@@ -506,68 +510,75 @@ type family PrefixRoute (prefix :: [Symbol]) route where
506510
PrefixRoute '[] route = route
507511
PrefixRoute (p ': rest) route = p :> PrefixRoute rest route
508512

509-
-- | 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.
510-
newtype ServantUnaryContentTypes = ServantUnaryContentTypes [Type]
513+
-- | ServantContentTypes represents that acceptable content types that can be used when a message in encoded:
514+
-- 1. in a unary (non-streaming) HTTP request\/response body,
515+
-- 2. encoded in a streaming HTTP request\/response body.
516+
-- It is used as an `AnnotatedSchema` domain.
517+
data ServantContentTypes
518+
= ServantContentTypes
519+
{ unary :: [Type]
520+
, stream :: Maybe ServantStreamContentType
521+
}
522+
523+
type DefaultServantContentTypes
524+
= 'ServantContentTypes '[JSON] ('Just ('ServantStreamContentType NewlineFraming JSON))
511525

512-
-- | 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.
513526
data ServantStreamContentType
514527
= ServantStreamContentType
515528
{ framing :: Type,
516529
streamContentType :: Type
517530
}
518531

519-
-- | 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`.
520-
newtype ServantMethod = ServantMethod StdMethod
521-
522-
-- | 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.
523-
newtype ServantStatus = ServantStatus Nat
524-
525532
-- extracts a StdMethod from a ServantMethod annotation of a given method, defaulting to POST if such an annotation doesn't exist
526533
type family HttpMethodFor pkg sname mname :: StdMethod where
527534
HttpMethodFor pkg sname mname =
528-
WithAnnotatedPackageInstance ServantMethod pkg (
529-
UnwrapServantMethod (FromMaybe ('ServantMethod 'POST) (GetMethodAnnotationMay (AnnotatedPackage ServantMethod pkg) sname mname))
535+
WithAnnotatedPackageInstance ServantRoute pkg (
536+
UnwrapServantMethod (FromMaybe ('ServantRoute Any 'POST Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname))
530537
)
531538

532539
type family UnwrapServantMethod m where
533-
UnwrapServantMethod ('ServantMethod m) = m
540+
UnwrapServantMethod ('ServantRoute _ m _) = m
534541

535542
-- extracts the HTTP status code from the ServantStatus annotation of a given method, or defaults to 200 if such an annotation doesn't exist
536543
type family HttpStatusFor pkg sname mname :: Nat where
537544
HttpStatusFor pkg sname mname =
538-
WithAnnotatedPackageInstance ServantStatus pkg (
539-
UnwrapServantStatus (FromMaybe ('ServantStatus 200) (GetMethodAnnotationMay (AnnotatedPackage ServantStatus pkg) sname mname))
545+
WithAnnotatedPackageInstance ServantRoute pkg (
546+
UnwrapServantStatus (FromMaybe ('ServantRoute Any Any 200) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname))
540547
)
541548

542549
type family UnwrapServantStatus s where
543-
UnwrapServantStatus ('ServantStatus s) = s
550+
UnwrapServantStatus ('ServantRoute _ _ s) = s
544551

545552
-- extracts a list of content types from a ServantUnaryContentTypes annotation of a given method
546553
type family UnaryContentTypesFor (tyRef :: TypeRef sname) :: [Type] where
547554
UnaryContentTypesFor ('SchemaRef schema typeName) =
548-
WithAnnotatedSchemaInstance ServantUnaryContentTypes schema (
549-
UnwrapServantUnaryContentType (GetTypeAnnotation (AnnotatedSchema ServantUnaryContentTypes schema) typeName)
555+
WithAnnotatedSchemaInstance ServantContentTypes schema (
556+
UnwrapServantUnaryContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
550557
)
551558

552-
type family UnwrapServantUnaryContentType (sctype :: ServantUnaryContentTypes) :: [Type] where
553-
UnwrapServantUnaryContentType ('ServantUnaryContentTypes ctype) = ctype
559+
type family UnwrapServantUnaryContentType (sctype :: ServantContentTypes) :: [Type] where
560+
UnwrapServantUnaryContentType ('ServantContentTypes ctype stype) = ctype
554561

555562
-- extracts a content type from a ServantStreamContentType annotation of a given method
556563
type family StreamContentTypeFor (tyRef :: TypeRef sname) :: Type where
557564
StreamContentTypeFor ('SchemaRef schema typeName) =
558-
WithAnnotatedSchemaInstance ServantStreamContentType schema (
559-
StreamContentType (GetTypeAnnotation (AnnotatedSchema ServantStreamContentType schema) typeName)
565+
WithAnnotatedSchemaInstance ServantContentTypes schema (
566+
StreamContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
560567
)
561568

562-
type family StreamContentType (sct :: ServantStreamContentType) where
563-
StreamContentType ('ServantStreamContentType _ ctype) = ctype
569+
type family StreamContentType (sct :: ServantContentTypes) where
570+
StreamContentType ('ServantContentTypes _ 'Nothing)
571+
= TypeError ('Text "missing stream content type")
572+
StreamContentType ('ServantContentTypes _ ('Just ('ServantStreamContentType _ ctype))) = ctype
564573

565574
-- extracts a framing from a ServantStreamContentType annotation of a given method
566575
type family StreamFramingFor (tyRef :: TypeRef sname) :: Type where
567576
StreamFramingFor ('SchemaRef schema typeName) =
568-
WithAnnotatedSchemaInstance ServantStreamContentType schema (
569-
StreamFraming (GetTypeAnnotation (AnnotatedSchema ServantStreamContentType schema) typeName)
577+
WithAnnotatedSchemaInstance ServantContentTypes schema (
578+
StreamFraming (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName)
570579
)
571580

572-
type family StreamFraming (sct :: ServantStreamContentType) where
573-
StreamFraming ('ServantStreamContentType framing _) = framing
581+
type family StreamFraming (sct :: ServantContentTypes) where
582+
StreamFraming ('ServantContentTypes _ 'Nothing)
583+
= TypeError ('Text "missing stream content type")
584+
StreamFraming ('ServantContentTypes _ ('Just ('ServantStreamContentType framing _))) = framing

0 commit comments

Comments
 (0)