git.iko.soy/servant
on master help sign in
Make error messages from combinators configurable

Currently there is no way for Servant users to customize formatting of error messages that arise when combinators can't parse URL or request body, apart from reimplementing those combinators for themselves or using middlewares. This commit adds a possibility to specify custom error formatters through Context. Fixes #685

commit57f0b0b390cc2e799f46622950a349d7bff18ef0 authorMaxim Koltsov <kolmax94@gmail.com> dateSun 14 Jun 2020, 12:15 (6 years ago) parent1f1f7f3
9 files changed+228−75
compare with master
unifiedsplit
servant-server/servant-server.cabal+2−1 servant-server/src/Servant/Server.hs+30−2 servant-server/src/Servant/Server/Generic.hs+1 servant-server/src/Servant/Server/Internal.hs+71−43 servant-server/src/Servant/Server/Internal/Context.hs+23−8 servant-server/src/Servant/Server/Internal/ErrorFormatter.hs+79 servant-server/src/Servant/Server/Internal/Router.hs+19−18 servant-server/test/Servant/Server/RouterSpec.hs+2−2 servant/src/Servant/API/Header.hs+1−1
servant-server/servant-server.cabal+2−1
@@ -50,9 +50,10 @@ library
5050 Servant.Server.Internal.Context
5151 Servant.Server.Internal.Delayed
5252 Servant.Server.Internal.DelayedIO
53+ Servant.Server.Internal.ErrorFormatter
5354 Servant.Server.Internal.Handler
54− Servant.Server.Internal.Router
5555 Servant.Server.Internal.RouteResult
56+ Servant.Server.Internal.Router
5657 Servant.Server.Internal.RoutingApplication
5758 Servant.Server.Internal.ServerError
5859 Servant.Server.StaticFiles
servant-server/src/Servant/Server.hs+30−2
@@ -3,6 +3,7 @@
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE RankNTypes #-}
55{-# LANGUAGE TypeFamilies #-}
6+{-# LANGUAGE TypeOperators #-}
67
78-- | This module lets you implement 'Server's for defined APIs. You'll
89-- most likely just need 'serve'.
@@ -35,6 +36,8 @@ module Servant.Server
3536 -- * Context
3637 , Context(..)
3738 , HasContextEntry(getContextEntry)
39+ , type (.++)
40+ , (.++)
3841 -- ** NamedContext
3942 , NamedContext(..)
4043 , descendIntoNamedContext
@@ -86,6 +89,24 @@ module Servant.Server
8689 , err504
8790 , err505
8891
92+ -- * Formatting of errors from combinators
93+ --
94+ -- | You can configure how Servant will render errors that occur while parsing the request.
95+
96+ , ErrorFormatter
97+ , NotFoundErrorFormatter
98+ , ErrorFormatters
99+
100+ , bodyParserErrorFormatter
101+ , urlParseErrorFormatter
102+ , headerParseErrorFormatter
103+ , notFoundErrorFormatter
104+
105+ , DefaultErrorFormatters
106+ , defaultErrorFormatters
107+
108+ , getAcceptHeader
109+
89110 -- * Re-exports
90111 , Application
91112 , Tagged (..)
@@ -129,10 +150,17 @@ import Servant.Server.Internal
129150serve :: (HasServer api '[]) => Proxy api -> Server api -> Application
130151serve p = serveWithContext p EmptyContext
131152
132−serveWithContext :: (HasServer api context)
153+-- | Like 'serve', but allows you to pass custom context.
154+--
155+-- 'defaultErrorFormatters' will always be appended to the end of the passed context,
156+-- but if you pass your own formatter, it will override the default one.
157+serveWithContext :: ( HasServer api context
158+ , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters )
133159 => Proxy api -> Context context -> Server api -> Application
134160serveWithContext p context server =
135− toApplication (runRouter (route p context (emptyDelayed (Route server))))
161+ toApplication (runRouter format404 (route p context (emptyDelayed (Route server))))
162+ where
163+ format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context
136164
137165-- | Hoist server implementation.
138166--
servant-server/src/Servant/Server/Generic.hs+1
@@ -67,6 +67,7 @@ genericServeTWithContext
6767 ( GenericServant routes (AsServerT m)
6868 , GenericServant routes AsApi
6969 , HasServer (ToServantApi routes) ctx
70+ , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters
7071 , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)
7172 )
7273 => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'
servant-server/src/Servant/Server/Internal.hs+71−43
@@ -24,6 +24,7 @@ module Servant.Server.Internal
2424 , module Servant.Server.Internal.Context
2525 , module Servant.Server.Internal.Delayed
2626 , module Servant.Server.Internal.DelayedIO
27+ , module Servant.Server.Internal.ErrorFormatter
2728 , module Servant.Server.Internal.Handler
2829 , module Servant.Server.Internal.Router
2930 , module Servant.Server.Internal.RouteResult
@@ -95,6 +96,7 @@ import Servant.Server.Internal.BasicAuth
9596import Servant.Server.Internal.Context
9697import Servant.Server.Internal.Delayed
9798import Servant.Server.Internal.DelayedIO
99+import Servant.Server.Internal.ErrorFormatter
98100import Servant.Server.Internal.Handler
99101import Servant.Server.Internal.Router
100102import Servant.Server.Internal.RouteResult
@@ -168,7 +170,10 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
168170-- > server = getBook
169171-- > where getBook :: Text -> Handler Book
170172-- > getBook isbn = ...
171−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods))
173+instance (KnownSymbol capture, FromHttpApiData a
174+ , HasServer api context, SBoolI (FoldLenient mods)
175+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
176+ )
172177 => HasServer (Capture' mods capture a :> api) context where
173178
174179 type ServerT (Capture' mods capture a :> api) m =
@@ -180,12 +185,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
180185 CaptureRouter $
181186 route (Proxy :: Proxy api)
182187 context
183− (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods)
184− , parseUrlPiece txt :: Either T.Text a) of
185− (SFalse, Left e) -> delayedFail err400 { errBody = cs e }
186− (SFalse, Right v) -> return v
187− (STrue, piece) -> return $ (either (Left . cs) Right) piece
188− )
188+ (addCapture d $ \ txt -> withRequest $ \ request ->
189+ case ( sbool :: SBool (FoldLenient mods)
190+ , parseUrlPiece txt :: Either T.Text a) of
191+ (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
192+ (SFalse, Right v) -> return v
193+ (STrue, piece) -> return $ (either (Left . cs) Right) piece)
194+ where
195+ rep = typeRep (Proxy :: Proxy Capture')
196+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
189197
190198-- | If you use 'CaptureAll' in one of the endpoints for your API,
191199-- this automatically requires your server-side handler to be a
@@ -204,7 +212,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
204212-- > server = getSourceFile
205213-- > where getSourceFile :: [Text] -> Handler Book
206214-- > getSourceFile pathSegments = ...
207−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
215+instance (KnownSymbol capture, FromHttpApiData a
216+ , HasServer api context
217+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
218+ )
208219 => HasServer (CaptureAll capture a :> api) context where
209220
210221 type ServerT (CaptureAll capture a :> api) m =
@@ -216,11 +227,14 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
216227 CaptureAllRouter $
217228 route (Proxy :: Proxy api)
218229 context
219− (addCapture d $ \ txts -> case parseUrlPieces txts of
220− Left _ -> delayedFail err400
221− Right v -> return v
230+ (addCapture d $ \ txts -> withRequest $ \ request ->
231+ case parseUrlPieces txts of
232+ Left e -> delayedFail $ formatError rep request $ cs e
233+ Right v -> return v
222234 )
223−
235+ where
236+ rep = typeRep (Proxy :: Proxy CaptureAll)
237+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
224238
225239allowedMethodHead :: Method -> Request -> Bool
226240allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
@@ -240,10 +254,10 @@ methodCheck method request
240254-- body check is no longer an option. However, we now run the accept
241255-- check before the body check and can therefore afford to make it
242256-- recoverable.
243−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
257+acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
244258acceptCheck proxy accH
245− | canHandleAcceptH proxy (AcceptHeader accH) = return ()
246− | otherwise = delayedFail err406
259+ | canHandleAcceptH proxy accH = return ()
260+ | otherwise = delayedFail err406
247261
248262methodRouter :: (AllCTRender ctypes a)
249263 => (b -> ([(HeaderName, B.ByteString)], a))
@@ -253,12 +267,12 @@ methodRouter :: (AllCTRender ctypes a)
253267methodRouter splitHeaders method proxy status action = leafRouter route'
254268 where
255269 route' env request respond =
256− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
270+ let accH = getAcceptHeader request
257271 in runAction (action `addMethodCheck` methodCheck method request
258272 `addAcceptCheck` acceptCheck proxy accH
259273 ) env request respond $ \ output -> do
260274 let (headers, b) = splitHeaders output
261− case handleAcceptH proxy (AcceptHeader accH) b of
275+ case handleAcceptH proxy accH b of
262276 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
263277 Just (contentT, body) ->
264278 let bdy = if allowedMethodHead method request then "" else body
@@ -343,7 +357,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
343357 -> Delayed env (Handler c)
344358 -> Router env
345359streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
346− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
360+ let AcceptHeader accH = getAcceptHeader request
347361 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
348362 accCheck = when (isNothing cmediatype) $ delayedFail err406
349363 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
@@ -388,6 +402,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
388402instance
389403 (KnownSymbol sym, FromHttpApiData a, HasServer api context
390404 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
405+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
391406 )
392407 => HasServer (Header' mods sym a :> api) context where
393408------
@@ -399,6 +414,9 @@ instance
399414 route Proxy context subserver = route (Proxy :: Proxy api) context $
400415 subserver `addHeaderCheck` withRequest headerCheck
401416 where
417+ rep = typeRep (Proxy :: Proxy Header')
418+ formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
419+
402420 headerName :: IsString n => n
403421 headerName = fromString $ symbolVal (Proxy :: Proxy sym)
404422
@@ -409,15 +427,13 @@ instance
409427 mev :: Maybe (Either T.Text a)
410428 mev = fmap parseHeader $ lookup headerName (requestHeaders req)
411429
412− errReq = delayedFailFatal err400
413− { errBody = "Header " <> headerName <> " is required"
414− }
430+ errReq = delayedFailFatal $ formatError rep req
431+ $ "Header " <> headerName <> " is required"
415432
416− errSt e = delayedFailFatal err400
417− { errBody = cs $ "Error parsing header "
418− <> headerName
419− <> " failed: " <> e
420− }
433+ errSt e = delayedFailFatal $ formatError rep req
434+ $ cs $ "Error parsing header "
435+ <> headerName
436+ <> " failed: " <> e
421437
422438-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
423439-- this automatically requires your server-side handler to be a function
@@ -443,6 +459,7 @@ instance
443459instance
444460 ( KnownSymbol sym, FromHttpApiData a, HasServer api context
445461 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
462+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
446463 )
447464 => HasServer (QueryParam' mods sym a :> api) context where
448465------
@@ -455,6 +472,9 @@ instance
455472 let querytext = queryToQueryText . queryString
456473 paramname = cs $ symbolVal (Proxy :: Proxy sym)
457474
475+ rep = typeRep (Proxy :: Proxy QueryParam')
476+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
477+
458478 parseParam :: Request -> DelayedIO (RequestArgument mods a)
459479 parseParam req =
460480 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
@@ -462,14 +482,12 @@ instance
462482 mev :: Maybe (Either T.Text a)
463483 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
464484
465− errReq = delayedFailFatal err400
466− { errBody = cs $ "Query parameter " <> paramname <> " is required"
467− }
485+ errReq = delayedFailFatal $ formatError rep req
486+ $ cs $ "Query parameter " <> paramname <> " is required"
468487
469− errSt e = delayedFailFatal err400
470− { errBody = cs $ "Error parsing query parameter "
471− <> paramname <> " failed: " <> e
472− }
488+ errSt e = delayedFailFatal $ formatError rep req
489+ $ cs $ "Error parsing query parameter "
490+ <> paramname <> " failed: " <> e
473491
474492 delayed = addParameterCheck subserver . withRequest $ \req ->
475493 parseParam req
@@ -495,7 +513,8 @@ instance
495513-- > server = getBooksBy
496514-- > where getBooksBy :: [Text] -> Handler [Book]
497515-- > getBooksBy authors = ...return all books by these authors...
498−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
516+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
517+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
499518 => HasServer (QueryParams sym a :> api) context where
500519
501520 type ServerT (QueryParams sym a :> api) m =
@@ -506,21 +525,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
506525 route Proxy context subserver = route (Proxy :: Proxy api) context $
507526 subserver `addParameterCheck` withRequest paramsCheck
508527 where
528+ rep = typeRep (Proxy :: Proxy QueryParams)
529+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
530+
509531 paramname = cs $ symbolVal (Proxy :: Proxy sym)
510532 paramsCheck req =
511533 case partitionEithers $ fmap parseQueryParam params of
512534 ([], parsed) -> return parsed
513− (errs, _) -> delayedFailFatal err400
514− { errBody = cs $ "Error parsing query parameter(s) "
515− <> paramname <> " failed: "
516− <> T.intercalate ", " errs
517− }
535+ (errs, _) -> delayedFailFatal $ formatError rep req
536+ $ cs $ "Error parsing query parameter(s) "
537+ <> paramname <> " failed: "
538+ <> T.intercalate ", " errs
518539 where
519540 params :: [T.Text]
520541 params = mapMaybe snd
521542 . filter (looksLikeParam . fst)
522− . queryToQueryText
523− . queryString
543+ . queryToQueryText
544+ . queryString
524545 $ req
525546
526547 looksLikeParam name = name == paramname || name == (paramname <> "[]")
@@ -588,7 +609,7 @@ instance HasServer Raw context where
588609-- The @Content-Type@ header is inspected, and the list provided is used to
589610-- attempt deserialization. If the request does not have a @Content-Type@
590611-- header, it is treated as @application/octet-stream@ (as specified in
591−-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
612+-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
592613-- This lets servant worry about extracting it from the request and turning
593614-- it into a value of the type you specify.
594615--
@@ -604,6 +625,7 @@ instance HasServer Raw context where
604625-- > where postBook :: Book -> Handler Book
605626-- > postBook book = ...insert into your db...
606627instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
628+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
607629 ) => HasServer (ReqBody' mods list a :> api) context where
608630
609631 type ServerT (ReqBody' mods list a :> api) m =
@@ -615,6 +637,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
615637 = route (Proxy :: Proxy api) context $
616638 addBodyCheck subserver ctCheck bodyCheck
617639 where
640+ rep = typeRep (Proxy :: Proxy ReqBody')
641+ formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
642+
618643 -- Content-Type check, we only lookup we can try to parse the request body
619644 ctCheck = withRequest $ \ request -> do
620645 -- See HTTP RFC 2616, section 7.2.1
@@ -633,7 +658,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
633658 case sbool :: SBool (FoldLenient mods) of
634659 STrue -> return mrqbody
635660 SFalse -> case mrqbody of
636− Left e -> delayedFailFatal err400 { errBody = cs e }
661+ Left e -> delayedFailFatal $ formatError rep request e
637662 Right v -> return v
638663
639664instance
@@ -761,6 +786,9 @@ instance ( KnownSymbol realm
761786ct_wildcard :: B.ByteString
762787ct_wildcard = "*" <> "/" <> "*" -- Because CPP
763788
789+getAcceptHeader :: Request -> AcceptHeader
790+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
791+
764792-- * General Authentication
765793
766794
servant-server/src/Servant/Server/Internal/Context.hs+23−8
@@ -1,11 +1,12 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE KindSignatures #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeOperators #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE KindSignatures #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
910
1011module Servant.Server.Internal.Context where
1112
@@ -45,6 +46,20 @@ instance Eq (Context '[]) where
4546instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
4647 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
4748
49+-- | Append two type-level lists.
50+--
51+-- Hint: import it as
52+--
53+-- > import Servant.Server (type (.++))
54+type family (.++) (l1 :: [*]) (l2 :: [*]) where
55+ '[] .++ a = a
56+ (a ': as) .++ b = a ': (as .++ b)
57+
58+-- | Append two contexts.
59+(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)
60+EmptyContext .++ a = a
61+(a :. as) .++ b = a :. (as .++ b)
62+
4863-- | This class is used to access context entries in 'Context's. 'getContextEntry'
4964-- returns the first value where the type matches:
5065--
servant-server/src/Servant/Server/Internal/ErrorFormatter.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE KindSignatures #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE TypeOperators #-}
6+
7+module Servant.Server.Internal.ErrorFormatter
8+ where
9+
10+import Data.String.Conversions
11+ (cs)
12+import Data.Typeable
13+import Network.Wai.Internal
14+ (Request)
15+
16+import Servant.API
17+ (Capture, ReqBody)
18+import Servant.Server.Internal.Context
19+import Servant.Server.Internal.ServerError
20+
21+-- | 'Context' that contains default error formatters.
22+type DefaultErrorFormatters = '[ErrorFormatters]
23+
24+-- | A collection of error formatters for different situations.
25+--
26+-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.
27+data ErrorFormatters = ErrorFormatters
28+ { -- | Format error from parsing the request body.
29+ bodyParserErrorFormatter :: ErrorFormatter
30+ -- | Format error from parsing url parts or query parameters.
31+ , urlParseErrorFormatter :: ErrorFormatter
32+ -- | Format error from parsing request headers.
33+ , headerParseErrorFormatter :: ErrorFormatter
34+ -- | Format error for not found URLs.
35+ , notFoundErrorFormatter :: NotFoundErrorFormatter
36+ }
37+
38+-- | Default formatters will just return HTTP 400 status code with error
39+-- message as response body.
40+defaultErrorFormatters :: ErrorFormatters
41+defaultErrorFormatters = ErrorFormatters
42+ { bodyParserErrorFormatter = err400Formatter
43+ , urlParseErrorFormatter = err400Formatter
44+ , headerParseErrorFormatter = err400Formatter
45+ , notFoundErrorFormatter = const err404
46+ }
47+
48+-- | A custom formatter for errors produced by parsing combinators like
49+-- 'ReqBody' or 'Capture'.
50+--
51+-- A 'TypeRep' argument described the concrete combinator that raised
52+-- the error, allowing formatter to customize the message for different
53+-- combinators.
54+--
55+-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,
56+-- for example.
57+type ErrorFormatter = TypeRep -> Request -> String -> ServerError
58+
59+-- | This formatter does not get neither 'TypeRep' nor error message.
60+type NotFoundErrorFormatter = Request -> ServerError
61+
62+type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters
63+
64+mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)
65+mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext)
66+
67+-- Internal
68+
69+err400Formatter :: ErrorFormatter
70+err400Formatter _ _ e = err400 { errBody = cs e }
71+
72+-- These definitions suppress "unused import" warning.
73+-- The imorts are needed for Haddock to correctly link to them.
74+_RB :: Proxy ReqBody
75+_RB = undefined
76+_C :: Proxy Capture
77+_C = undefined
78+_CT :: Proxy Context
79+_CT = undefined
servant-server/src/Servant/Server/Internal/Router.hs+19−18
@@ -17,8 +17,9 @@ import Data.Text
1717import qualified Data.Text as T
1818import Network.Wai
1919 (Response, pathInfo)
20−import Servant.Server.Internal.RoutingApplication
20+import Servant.Server.Internal.ErrorFormatter
2121import Servant.Server.Internal.RouteResult
22+import Servant.Server.Internal.RoutingApplication
2223import Servant.Server.Internal.ServerError
2324
2425type Router env = Router' env RoutingApplication
@@ -153,52 +154,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env ->
153154tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
154155
155156-- | Interpret a router as an application.
156−runRouter :: Router () -> RoutingApplication
157−runRouter r = runRouterEnv r ()
157+runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication
158+runRouter fmt r = runRouterEnv fmt r ()
158159
159−runRouterEnv :: Router env -> env -> RoutingApplication
160−runRouterEnv router env request respond =
160+runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
161+runRouterEnv fmt router env request respond =
161162 case router of
162163 StaticRouter table ls ->
163164 case pathInfo request of
164− [] -> runChoice ls env request respond
165+ [] -> runChoice fmt ls env request respond
165166 -- This case is to handle trailing slashes.
166− [""] -> runChoice ls env request respond
167+ [""] -> runChoice fmt ls env request respond
167168 first : rest | Just router' <- M.lookup first table
168169 -> let request' = request { pathInfo = rest }
169− in runRouterEnv router' env request' respond
170− _ -> respond $ Fail err404
170+ in runRouterEnv fmt router' env request' respond
171+ _ -> respond $ Fail $ fmt request
171172 CaptureRouter router' ->
172173 case pathInfo request of
173− [] -> respond $ Fail err404
174+ [] -> respond $ Fail $ fmt request
174175 -- This case is to handle trailing slashes.
175− [""] -> respond $ Fail err404
176+ [""] -> respond $ Fail $ fmt request
176177 first : rest
177178 -> let request' = request { pathInfo = rest }
178− in runRouterEnv router' (first, env) request' respond
179+ in runRouterEnv fmt router' (first, env) request' respond
179180 CaptureAllRouter router' ->
180181 let segments = pathInfo request
181182 request' = request { pathInfo = [] }
182− in runRouterEnv router' (segments, env) request' respond
183+ in runRouterEnv fmt router' (segments, env) request' respond
183184 RawRouter app ->
184185 app env request respond
185186 Choice r1 r2 ->
186− runChoice [runRouterEnv r1, runRouterEnv r2] env request respond
187+ runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond
187188
188189-- | Try a list of routing applications in order.
189190-- We stop as soon as one fails fatally or succeeds.
190191-- If all fail normally, we pick the "best" error.
191192--
192−runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication
193−runChoice ls =
193+runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication
194+runChoice fmt ls =
194195 case ls of
195− [] -> \ _ _ respond -> respond (Fail err404)
196+ [] -> \ _ request respond -> respond (Fail $ fmt request)
196197 [r] -> r
197198 (r : rs) ->
198199 \ env request respond ->
199200 r env request $ \ response1 ->
200201 case response1 of
201− Fail _ -> runChoice rs env request $ \ response2 ->
202+ Fail _ -> runChoice fmt rs env request $ \ response2 ->
202203 respond $ highestPri response1 response2
203204 _ -> respond response1
204205 where
servant-server/test/Servant/Server/RouterSpec.hs+2−2
@@ -32,7 +32,7 @@ routerSpec :: Spec
3232routerSpec = do
3333 describe "tweakResponse" $ do
3434 let app' :: Application
35− app' = toApplication $ runRouter router'
35+ app' = toApplication $ runRouter (const err404) router'
3636
3737 router', router :: Router ()
3838 router' = tweakResponse (fmap twk) router
@@ -48,7 +48,7 @@ routerSpec = do
4848
4949 describe "runRouter" $ do
5050 let toApp :: Router () -> Application
51− toApp = toApplication . runRouter
51+ toApp = toApplication . runRouter (const err404)
5252
5353 cap :: Router ()
5454 cap = CaptureRouter $
servant/src/Servant/API/Header.hs+1−1
@@ -23,7 +23,7 @@ import Servant.API.Modifiers
2323-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer
2424type Header = Header' '[Optional, Strict]
2525
26−data Header' (mods :: [*]) (sym :: Symbol) a
26+data Header' (mods :: [*]) (sym :: Symbol) (a :: *)
2727 deriving Typeable
2828
2929-- $setup