@@ -120,6 +120,56 @@ instance (KnownSymbol capture, FromText a, HasServer sublayout)
120120 where captureProxy = Proxy :: Proxy (Capture capture a)
121121
122122
123+methodRouter :: (AllCTRender ctypes a)
124+ => Method -> Proxy ctypes -> Status
125+ -> IO (RouteResult (EitherT ServantErr IO a))
126+ -> Router
127+methodRouter method proxy status action = LeafRouter route'
128+ where
129+ route' request respond
130+ | pathIsEmpty request && requestMethod request == method = do
131+ runAction action respond $ \ output -> do
132+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
133+ case handleAcceptH proxy (AcceptHeader accH) output of
134+ Nothing -> failWith UnsupportedMediaType
135+ Just (contentT, body) -> succeedWith $
136+ responseLBS status [ ("Content-Type" , cs contentT)] body
137+ | pathIsEmpty request && requestMethod request /= method =
138+ respond $ failWith WrongMethod
139+ | otherwise = respond $ failWith NotFound
140+
141+methodRouterHeaders :: (GetHeaders (Headers h v), AllCTRender ctypes v)
142+ => Method -> Proxy ctypes -> Status
143+ -> IO (RouteResult (EitherT ServantErr IO (Headers h v)))
144+ -> Router
145+methodRouterHeaders method proxy status action = LeafRouter route'
146+ where
147+ route' request respond
148+ | pathIsEmpty request && requestMethod request == method = do
149+ runAction action respond $ \ output -> do
150+ let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
151+ headers = getHeaders output
152+ case handleAcceptH proxy (AcceptHeader accH) (getResponse output) of
153+ Nothing -> failWith UnsupportedMediaType
154+ Just (contentT, body) -> succeedWith $
155+ responseLBS status ( ("Content-Type" , cs contentT) : headers) body
156+ | pathIsEmpty request && requestMethod request /= method =
157+ respond $ failWith WrongMethod
158+ | otherwise = respond $ failWith NotFound
159+
160+methodRouterEmpty :: Method
161+ -> IO (RouteResult (EitherT ServantErr IO ()))
162+ -> Router
163+methodRouterEmpty method action = LeafRouter route'
164+ where
165+ route' request respond
166+ | pathIsEmpty request && requestMethod request == method = do
167+ runAction action respond $ \ () ->
168+ succeedWith $ responseLBS noContent204 [] ""
169+ | pathIsEmpty request && requestMethod request /= method =
170+ respond $ failWith WrongMethod
171+ | otherwise = respond $ failWith NotFound
172+
123173-- | If you have a 'Delete' endpoint in your API,
124174-- the handler for this endpoint is meant to delete
125175-- a resource.
@@ -140,19 +190,7 @@ instance
140190
141191 type ServerT (Delete ctypes a) m = m a
142192
143− route Proxy action = LeafRouter route'
144− where
145− route' request respond
146− | pathIsEmpty request && requestMethod request == methodDelete = do
147− runAction action respond $ \ output -> do
148− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
149− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
150− Nothing -> failWith UnsupportedMediaType
151− Just (contentT, body) -> succeedWith $
152− responseLBS status200 [ ("Content-Type" , cs contentT)] body
153− | pathIsEmpty request && requestMethod request /= methodDelete =
154− respond $ failWith WrongMethod
155− | otherwise = respond $ failWith NotFound
193+ route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200
156194
157195instance
158196#if MIN_VERSION_base(4,8,0)
@@ -162,15 +200,7 @@ instance
162200
163201 type ServerT (Delete ctypes ()) m = m ()
164202
165− route Proxy action = LeafRouter route'
166− where
167− route' request respond
168− | pathIsEmpty request && requestMethod request == methodDelete = do
169− runAction action respond $ \ () ->
170− succeedWith $ responseLBS noContent204 [] ""
171− | pathIsEmpty request && requestMethod request /= methodDelete =
172− respond $ failWith WrongMethod
173− | otherwise = respond $ failWith NotFound
203+ route Proxy = methodRouterEmpty methodDelete
174204
175205-- Add response headers
176206instance
@@ -182,20 +212,7 @@ instance
182212
183213 type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v)
184214
185− route Proxy action = LeafRouter route'
186− where
187− route' request respond
188− | pathIsEmpty request && requestMethod request == methodDelete = do
189− runAction action respond $ \ output -> do
190− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
191− headers = getHeaders output
192− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
193− Nothing -> failWith UnsupportedMediaType
194− Just (contentT, body) -> succeedWith $
195− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
196− | pathIsEmpty request && requestMethod request /= methodDelete =
197− respond $ failWith WrongMethod
198− | otherwise = respond $ failWith NotFound
215+ route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200
199216
200217-- | When implementing the handler for a 'Get' endpoint,
201218-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post'
@@ -218,19 +235,7 @@ instance
218235
219236 type ServerT (Get ctypes a) m = m a
220237
221− route Proxy action = LeafRouter route'
222− where
223− route' request respond
224− | pathIsEmpty request && requestMethod request == methodGet = do
225− runAction action respond $ \ output -> do
226− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
227− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
228− Nothing -> failWith UnsupportedMediaType
229− Just (contentT, body) -> succeedWith $
230− responseLBS ok200 [ ("Content-Type" , cs contentT)] body
231− | pathIsEmpty request && requestMethod request /= methodGet =
232− respond $ failWith WrongMethod
233− | otherwise = respond $ failWith NotFound
238+ route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200
234239
235240-- '()' ==> 204 No Content
236241instance
@@ -241,15 +246,7 @@ instance
241246
242247 type ServerT (Get ctypes ()) m = m ()
243248
244− route Proxy action = LeafRouter route'
245− where
246− route' request respond
247− | pathIsEmpty request && requestMethod request == methodGet = do
248− runAction action respond $ \ () ->
249− succeedWith $ responseLBS noContent204 [] ""
250− | pathIsEmpty request && requestMethod request /= methodGet =
251− respond $ failWith WrongMethod
252− | otherwise = respond $ failWith NotFound
249+ route Proxy = methodRouterEmpty methodGet
253250
254251-- Add response headers
255252instance
@@ -261,20 +258,7 @@ instance
261258
262259 type ServerT (Get ctypes (Headers h v)) m = m (Headers h v)
263260
264− route Proxy action = LeafRouter route'
265− where
266− route' request respond
267− | pathIsEmpty request && requestMethod request == methodGet = do
268− runAction action respond $ \ output -> do
269− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
270− headers = getHeaders output
271− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
272− Nothing -> failWith UnsupportedMediaType
273− Just (contentT, body) -> succeedWith $
274− responseLBS ok200 ( ("Content-Type" , cs contentT) : headers) body
275− | pathIsEmpty request && requestMethod request /= methodGet =
276− respond $ failWith WrongMethod
277− | otherwise = respond $ failWith NotFound
261+ route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200
278262
279263-- | If you use 'Header' in one of the endpoints for your API,
280264-- this automatically requires your server-side handler to be a function
@@ -329,19 +313,7 @@ instance
329313
330314 type ServerT (Post ctypes a) m = m a
331315
332− route Proxy action = LeafRouter route'
333− where
334− route' request respond
335− | pathIsEmpty request && requestMethod request == methodPost = do
336− runAction action respond $ \ output -> do
337− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
338− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
339− Nothing -> failWith UnsupportedMediaType
340− Just (contentT, body) -> succeedWith $
341− responseLBS status201 [ ("Content-Type" , cs contentT)] body
342− | pathIsEmpty request && requestMethod request /= methodPost =
343− respond $ failWith WrongMethod
344− | otherwise = respond $ failWith NotFound
316+ route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201
345317
346318instance
347319#if MIN_VERSION_base(4,8,0)
@@ -351,15 +323,7 @@ instance
351323
352324 type ServerT (Post ctypes ()) m = m ()
353325
354− route Proxy action = LeafRouter route'
355− where
356− route' request respond
357− | pathIsEmpty request && requestMethod request == methodPost = do
358− runAction action respond $ \ () ->
359− succeedWith $ responseLBS noContent204 [] ""
360− | pathIsEmpty request && requestMethod request /= methodPost =
361− respond $ failWith WrongMethod
362− | otherwise = respond $ failWith NotFound
326+ route Proxy = methodRouterEmpty methodPost
363327
364328-- Add response headers
365329instance
@@ -371,20 +335,7 @@ instance
371335
372336 type ServerT (Post ctypes (Headers h v)) m = m (Headers h v)
373337
374− route Proxy action = LeafRouter route'
375− where
376− route' request respond
377− | pathIsEmpty request && requestMethod request == methodPost = do
378− runAction action respond $ \ output -> do
379− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
380− headers = getHeaders output
381− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
382− Nothing -> failWith UnsupportedMediaType
383− Just (contentT, body) -> succeedWith $
384− responseLBS status201 ( ("Content-Type" , cs contentT) : headers) body
385− | pathIsEmpty request && requestMethod request /= methodPost =
386− respond $ failWith WrongMethod
387− | otherwise = respond $ failWith NotFound
338+ route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201
388339
389340-- | When implementing the handler for a 'Put' endpoint,
390341-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@@ -407,19 +358,7 @@ instance
407358
408359 type ServerT (Put ctypes a) m = m a
409360
410− route Proxy action = LeafRouter route'
411− where
412− route' request respond
413− | pathIsEmpty request && requestMethod request == methodPut = do
414− runAction action respond $ \ output -> do
415− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
416− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
417− Nothing -> failWith UnsupportedMediaType
418− Just (contentT, body) -> succeedWith $
419− responseLBS status200 [ ("Content-Type" , cs contentT)] body
420− | pathIsEmpty request && requestMethod request /= methodPut =
421− respond $ failWith WrongMethod
422− | otherwise = respond $ failWith NotFound
361+ route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200
423362
424363instance
425364#if MIN_VERSION_base(4,8,0)
@@ -429,15 +368,7 @@ instance
429368
430369 type ServerT (Put ctypes ()) m = m ()
431370
432− route Proxy action = LeafRouter route'
433− where
434− route' request respond
435− | pathIsEmpty request && requestMethod request == methodPut = do
436− runAction action respond $ \ () ->
437− succeedWith $ responseLBS noContent204 [] ""
438− | pathIsEmpty request && requestMethod request /= methodPut =
439− respond $ failWith WrongMethod
440− | otherwise = respond $ failWith NotFound
371+ route Proxy = methodRouterEmpty methodPut
441372
442373-- Add response headers
443374instance
@@ -449,20 +380,7 @@ instance
449380
450381 type ServerT (Put ctypes (Headers h v)) m = m (Headers h v)
451382
452− route Proxy action = LeafRouter route'
453− where
454− route' request respond
455− | pathIsEmpty request && requestMethod request == methodPut = do
456− runAction action respond $ \ output -> do
457− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
458− headers = getHeaders output
459− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse output) of
460− Nothing -> failWith UnsupportedMediaType
461− Just (contentT, body) -> succeedWith $
462− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
463− | pathIsEmpty request && requestMethod request /= methodPut =
464− respond $ failWith WrongMethod
465− | otherwise = respond $ failWith NotFound
383+ route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200
466384
467385-- | When implementing the handler for a 'Patch' endpoint,
468386-- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get'
@@ -483,19 +401,7 @@ instance
483401
484402 type ServerT (Patch ctypes a) m = m a
485403
486− route Proxy action = LeafRouter route'
487− where
488− route' request respond
489− | pathIsEmpty request && requestMethod request == methodPatch = do
490− runAction action respond $ \ output -> do
491− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
492− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) output of
493− Nothing -> failWith UnsupportedMediaType
494− Just (contentT, body) -> succeedWith $
495− responseLBS status200 [ ("Content-Type" , cs contentT)] body
496− | pathIsEmpty request && requestMethod request /= methodPatch =
497− respond $ failWith WrongMethod
498− | otherwise = respond $ failWith NotFound
404+ route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200
499405
500406instance
501407#if MIN_VERSION_base(4,8,0)
@@ -505,15 +411,7 @@ instance
505411
506412 type ServerT (Patch ctypes ()) m = m ()
507413
508− route Proxy action = LeafRouter route'
509− where
510− route' request respond
511− | pathIsEmpty request && requestMethod request == methodPatch = do
512− runAction action respond $ \ () ->
513− succeedWith $ responseLBS noContent204 [] ""
514− | pathIsEmpty request && requestMethod request /= methodPatch =
515− respond $ failWith WrongMethod
516− | otherwise = respond $ failWith NotFound
414+ route Proxy = methodRouterEmpty methodPatch
517415
518416-- Add response headers
519417instance
@@ -525,20 +423,7 @@ instance
525423
526424 type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v)
527425
528− route Proxy action = LeafRouter route'
529− where
530− route' request respond
531− | pathIsEmpty request && requestMethod request == methodPatch = do
532− runAction action respond $ \ outpatch -> do
533− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
534− headers = getHeaders outpatch
535− case handleAcceptH (Proxy :: Proxy ctypes) (AcceptHeader accH) (getResponse outpatch) of
536− Nothing -> failWith UnsupportedMediaType
537− Just (contentT, body) -> succeedWith $
538− responseLBS status200 ( ("Content-Type" , cs contentT) : headers) body
539− | pathIsEmpty request && requestMethod request /= methodPatch =
540− respond $ failWith WrongMethod
541− | otherwise = respond $ failWith NotFound
426+ route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200
542427
543428-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
544429-- this automatically requires your server-side handler to be a function