From df2f16463fe14ca5f7e71a5b7d2ee6421e5bdeb0 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Sun, 14 Jun 2020 12:15:30 +0300 Subject: [PATCH] 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 --- servant-server/servant-server.cabal | 3 +- servant-server/src/Servant/Server.hs | 32 ++++- servant-server/src/Servant/Server/Generic.hs | 1 + servant-server/src/Servant/Server/Internal.hs | 114 +++++++++++------- .../src/Servant/Server/Internal/Context.hs | 31 +++-- .../Servant/Server/Internal/ErrorFormatter.hs | 79 ++++++++++++ .../src/Servant/Server/Internal/Router.hs | 37 +++--- .../test/Servant/Server/RouterSpec.hs | 4 +- servant/src/Servant/API/Header.hs | 2 +- 9 files changed, 228 insertions(+), 75 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/ErrorFormatter.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 26c017d95..d51f210d8 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -50,9 +50,10 @@ library Servant.Server.Internal.Context Servant.Server.Internal.Delayed Servant.Server.Internal.DelayedIO + Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler - Servant.Server.Internal.Router Servant.Server.Internal.RouteResult + Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index e2d9f3c5a..99c0b1e59 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. @@ -35,6 +36,8 @@ module Servant.Server -- * Context , Context(..) , HasContextEntry(getContextEntry) + , type (.++) + , (.++) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext @@ -86,6 +89,24 @@ module Servant.Server , err504 , err505 + -- * Formatting of errors from combinators + -- + -- | You can configure how Servant will render errors that occur while parsing the request. + + , ErrorFormatter + , NotFoundErrorFormatter + , ErrorFormatters + + , bodyParserErrorFormatter + , urlParseErrorFormatter + , headerParseErrorFormatter + , notFoundErrorFormatter + + , DefaultErrorFormatters + , defaultErrorFormatters + + , getAcceptHeader + -- * Re-exports , Application , Tagged (..) @@ -129,10 +150,17 @@ import Servant.Server.Internal serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve p = serveWithContext p EmptyContext -serveWithContext :: (HasServer api context) +-- | Like 'serve', but allows you to pass custom context. +-- +-- 'defaultErrorFormatters' will always be appended to the end of the passed context, +-- but if you pass your own formatter, it will override the default one. +serveWithContext :: ( HasServer api context + , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters ) => Proxy api -> Context context -> Server api -> Application serveWithContext p context server = - toApplication (runRouter (route p context (emptyDelayed (Route server)))) + toApplication (runRouter format404 (route p context (emptyDelayed (Route server)))) + where + format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context -- | Hoist server implementation. -- diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index 88dbe3313..c3db01c3d 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -67,6 +67,7 @@ genericServeTWithContext ( GenericServant routes (AsServerT m) , GenericServant routes AsApi , HasServer (ToServantApi routes) ctx + , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) ) => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index b9597aa60..9fa0187b4 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -24,6 +24,7 @@ module Servant.Server.Internal , module Servant.Server.Internal.Context , module Servant.Server.Internal.Delayed , module Servant.Server.Internal.DelayedIO + , module Servant.Server.Internal.ErrorFormatter , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RouteResult @@ -95,6 +96,7 @@ import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context import Servant.Server.Internal.Delayed import Servant.Server.Internal.DelayedIO +import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RouteResult @@ -168,7 +170,10 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods)) +instance (KnownSymbol capture, FromHttpApiData a + , HasServer api context, SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => HasServer (Capture' mods capture a :> api) context where type ServerT (Capture' mods capture a :> api) m = @@ -180,12 +185,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI CaptureRouter $ route (Proxy :: Proxy api) context - (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods) - , parseUrlPiece txt :: Either T.Text a) of - (SFalse, Left e) -> delayedFail err400 { errBody = cs e } - (SFalse, Right v) -> return v - (STrue, piece) -> return $ (either (Left . cs) Right) piece - ) + (addCapture d $ \ txt -> withRequest $ \ request -> + case ( sbool :: SBool (FoldLenient mods) + , parseUrlPiece txt :: Either T.Text a) of + (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e + (SFalse, Right v) -> return v + (STrue, piece) -> return $ (either (Left . cs) Right) piece) + where + rep = typeRep (Proxy :: Proxy Capture') + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) -- | If you use 'CaptureAll' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a @@ -204,7 +212,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) +instance (KnownSymbol capture, FromHttpApiData a + , HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => HasServer (CaptureAll capture a :> api) context where type ServerT (CaptureAll capture a :> api) m = @@ -216,11 +227,14 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) CaptureAllRouter $ route (Proxy :: Proxy api) context - (addCapture d $ \ txts -> case parseUrlPieces txts of - Left _ -> delayedFail err400 - Right v -> return v + (addCapture d $ \ txts -> withRequest $ \ request -> + case parseUrlPieces txts of + Left e -> delayedFail $ formatError rep request $ cs e + Right v -> return v ) - + where + rep = typeRep (Proxy :: Proxy CaptureAll) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -240,10 +254,10 @@ methodCheck method request -- body check is no longer an option. However, we now run the accept -- check before the body check and can therefore afford to make it -- recoverable. -acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () +acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO () acceptCheck proxy accH - | canHandleAcceptH proxy (AcceptHeader accH) = return () - | otherwise = delayedFail err406 + | canHandleAcceptH proxy accH = return () + | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => (b -> ([(HeaderName, B.ByteString)], a)) @@ -253,12 +267,12 @@ methodRouter :: (AllCTRender ctypes a) methodRouter splitHeaders method proxy status action = leafRouter route' where route' env request respond = - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + let accH = getAcceptHeader request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let (headers, b) = splitHeaders output - case handleAcceptH proxy (AcceptHeader accH) b of + case handleAcceptH proxy accH b of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> 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 -> Delayed env (Handler c) -> Router env streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + let AcceptHeader accH = getAcceptHeader request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) @@ -388,6 +402,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou instance (KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (Header' mods sym a :> api) context where ------ @@ -399,6 +414,9 @@ instance route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where + rep = typeRep (Proxy :: Proxy Header') + formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + headerName :: IsString n => n headerName = fromString $ symbolVal (Proxy :: Proxy sym) @@ -409,15 +427,13 @@ instance mev :: Maybe (Either T.Text a) mev = fmap parseHeader $ lookup headerName (requestHeaders req) - errReq = delayedFailFatal err400 - { errBody = "Header " <> headerName <> " is required" - } + errReq = delayedFailFatal $ formatError rep req + $ "Header " <> headerName <> " is required" - errSt e = delayedFailFatal err400 - { errBody = cs $ "Error parsing header " - <> headerName - <> " failed: " <> e - } + errSt e = delayedFailFatal $ formatError rep req + $ cs $ "Error parsing header " + <> headerName + <> " failed: " <> e -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -443,6 +459,7 @@ instance instance ( KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (QueryParam' mods sym a :> api) context where ------ @@ -455,6 +472,9 @@ instance let querytext = queryToQueryText . queryString paramname = cs $ symbolVal (Proxy :: Proxy sym) + rep = typeRep (Proxy :: Proxy QueryParam') + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + parseParam :: Request -> DelayedIO (RequestArgument mods a) parseParam req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev @@ -462,14 +482,12 @@ instance mev :: Maybe (Either T.Text a) mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req - errReq = delayedFailFatal err400 - { errBody = cs $ "Query parameter " <> paramname <> " is required" - } + errReq = delayedFailFatal $ formatError rep req + $ cs $ "Query parameter " <> paramname <> " is required" - errSt e = delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter " - <> paramname <> " failed: " <> e - } + errSt e = delayedFailFatal $ formatError rep req + $ cs $ "Error parsing query parameter " + <> paramname <> " failed: " <> e delayed = addParameterCheck subserver . withRequest $ \req -> parseParam req @@ -495,7 +513,8 @@ instance -- > server = getBooksBy -- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters) => HasServer (QueryParams sym a :> api) context where type ServerT (QueryParams sym a :> api) m = @@ -506,21 +525,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addParameterCheck` withRequest paramsCheck where + rep = typeRep (Proxy :: Proxy QueryParams) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + paramname = cs $ symbolVal (Proxy :: Proxy sym) paramsCheck req = case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed - (errs, _) -> delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter(s) " - <> paramname <> " failed: " - <> T.intercalate ", " errs - } + (errs, _) -> delayedFailFatal $ formatError rep req + $ cs $ "Error parsing query parameter(s) " + <> paramname <> " failed: " + <> T.intercalate ", " errs where params :: [T.Text] params = mapMaybe snd . filter (looksLikeParam . fst) - . queryToQueryText - . queryString + . queryToQueryText + . queryString $ req looksLikeParam name = name == paramname || name == (paramname <> "[]") @@ -588,7 +609,7 @@ instance HasServer Raw context where -- The @Content-Type@ header is inspected, and the list provided is used to -- attempt deserialization. If the request does not have a @Content-Type@ -- header, it is treated as @application/octet-stream@ (as specified in --- . +-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)). -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- @@ -604,6 +625,7 @@ instance HasServer Raw context where -- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (ReqBody' mods list a :> api) context where type ServerT (ReqBody' mods list a :> api) m = @@ -615,6 +637,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where + rep = typeRep (Proxy :: Proxy ReqBody') + formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + -- Content-Type check, we only lookup we can try to parse the request body ctCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 @@ -633,7 +658,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods case sbool :: SBool (FoldLenient mods) of STrue -> return mrqbody SFalse -> case mrqbody of - Left e -> delayedFailFatal err400 { errBody = cs e } + Left e -> delayedFailFatal $ formatError rep request e Right v -> return v instance @@ -761,6 +786,9 @@ instance ( KnownSymbol realm ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP +getAcceptHeader :: Request -> AcceptHeader +getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders + -- * General Authentication diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs index 9472cbbac..cb4c23bee 100644 --- a/servant-server/src/Servant/Server/Internal/Context.hs +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.Context where @@ -45,6 +46,20 @@ instance Eq (Context '[]) where instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 +-- | Append two type-level lists. +-- +-- Hint: import it as +-- +-- > import Servant.Server (type (.++)) +type family (.++) (l1 :: [*]) (l2 :: [*]) where + '[] .++ a = a + (a ': as) .++ b = a ': (as .++ b) + +-- | Append two contexts. +(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2) +EmptyContext .++ a = a +(a :. as) .++ b = a :. (as .++ b) + -- | This class is used to access context entries in 'Context's. 'getContextEntry' -- returns the first value where the type matches: -- diff --git a/servant-server/src/Servant/Server/Internal/ErrorFormatter.hs b/servant-server/src/Servant/Server/Internal/ErrorFormatter.hs new file mode 100644 index 000000000..c5a7b221f --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/ErrorFormatter.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.Internal.ErrorFormatter + where + +import Data.String.Conversions + (cs) +import Data.Typeable +import Network.Wai.Internal + (Request) + +import Servant.API + (Capture, ReqBody) +import Servant.Server.Internal.Context +import Servant.Server.Internal.ServerError + +-- | 'Context' that contains default error formatters. +type DefaultErrorFormatters = '[ErrorFormatters] + +-- | A collection of error formatters for different situations. +-- +-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax. +data ErrorFormatters = ErrorFormatters + { -- | Format error from parsing the request body. + bodyParserErrorFormatter :: ErrorFormatter + -- | Format error from parsing url parts or query parameters. + , urlParseErrorFormatter :: ErrorFormatter + -- | Format error from parsing request headers. + , headerParseErrorFormatter :: ErrorFormatter + -- | Format error for not found URLs. + , notFoundErrorFormatter :: NotFoundErrorFormatter + } + +-- | Default formatters will just return HTTP 400 status code with error +-- message as response body. +defaultErrorFormatters :: ErrorFormatters +defaultErrorFormatters = ErrorFormatters + { bodyParserErrorFormatter = err400Formatter + , urlParseErrorFormatter = err400Formatter + , headerParseErrorFormatter = err400Formatter + , notFoundErrorFormatter = const err404 + } + +-- | A custom formatter for errors produced by parsing combinators like +-- 'ReqBody' or 'Capture'. +-- +-- A 'TypeRep' argument described the concrete combinator that raised +-- the error, allowing formatter to customize the message for different +-- combinators. +-- +-- A full 'Request' is also passed so that the formatter can react to @Accept@ header, +-- for example. +type ErrorFormatter = TypeRep -> Request -> String -> ServerError + +-- | This formatter does not get neither 'TypeRep' nor error message. +type NotFoundErrorFormatter = Request -> ServerError + +type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters + +mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx) +mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext) + +-- Internal + +err400Formatter :: ErrorFormatter +err400Formatter _ _ e = err400 { errBody = cs e } + +-- These definitions suppress "unused import" warning. +-- The imorts are needed for Haddock to correctly link to them. +_RB :: Proxy ReqBody +_RB = undefined +_C :: Proxy Capture +_C = undefined +_CT :: Proxy Context +_CT = undefined diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index d6735c9e9..ecee59018 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -17,8 +17,9 @@ import Data.Text import qualified Data.Text as T import Network.Wai (Response, pathInfo) -import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError type Router env = Router' env RoutingApplication @@ -153,52 +154,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) -- | Interpret a router as an application. -runRouter :: Router () -> RoutingApplication -runRouter r = runRouterEnv r () +runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication +runRouter fmt r = runRouterEnv fmt r () -runRouterEnv :: Router env -> env -> RoutingApplication -runRouterEnv router env request respond = +runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication +runRouterEnv fmt router env request respond = case router of StaticRouter table ls -> case pathInfo request of - [] -> runChoice ls env request respond + [] -> runChoice fmt ls env request respond -- This case is to handle trailing slashes. - [""] -> runChoice ls env request respond + [""] -> runChoice fmt ls env request respond first : rest | Just router' <- M.lookup first table -> let request' = request { pathInfo = rest } - in runRouterEnv router' env request' respond - _ -> respond $ Fail err404 + in runRouterEnv fmt router' env request' respond + _ -> respond $ Fail $ fmt request CaptureRouter router' -> case pathInfo request of - [] -> respond $ Fail err404 + [] -> respond $ Fail $ fmt request -- This case is to handle trailing slashes. - [""] -> respond $ Fail err404 + [""] -> respond $ Fail $ fmt request first : rest -> let request' = request { pathInfo = rest } - in runRouterEnv router' (first, env) request' respond + in runRouterEnv fmt router' (first, env) request' respond CaptureAllRouter router' -> let segments = pathInfo request request' = request { pathInfo = [] } - in runRouterEnv router' (segments, env) request' respond + in runRouterEnv fmt router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 -> - runChoice [runRouterEnv r1, runRouterEnv r2] env request respond + runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond -- | Try a list of routing applications in order. -- We stop as soon as one fails fatally or succeeds. -- If all fail normally, we pick the "best" error. -- -runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication -runChoice ls = +runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication +runChoice fmt ls = case ls of - [] -> \ _ _ respond -> respond (Fail err404) + [] -> \ _ request respond -> respond (Fail $ fmt request) [r] -> r (r : rs) -> \ env request respond -> r env request $ \ response1 -> case response1 of - Fail _ -> runChoice rs env request $ \ response2 -> + Fail _ -> runChoice fmt rs env request $ \ response2 -> respond $ highestPri response1 response2 _ -> respond response1 where diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 472dfecc4..9b69a2e7c 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -32,7 +32,7 @@ routerSpec :: Spec routerSpec = do describe "tweakResponse" $ do let app' :: Application - app' = toApplication $ runRouter router' + app' = toApplication $ runRouter (const err404) router' router', router :: Router () router' = tweakResponse (fmap twk) router @@ -48,7 +48,7 @@ routerSpec = do describe "runRouter" $ do let toApp :: Router () -> Application - toApp = toApplication . runRouter + toApp = toApplication . runRouter (const err404) cap :: Router () cap = CaptureRouter $ diff --git a/servant/src/Servant/API/Header.hs b/servant/src/Servant/API/Header.hs index 14562dfc5..e5ea1e009 100644 --- a/servant/src/Servant/API/Header.hs +++ b/servant/src/Servant/API/Header.hs @@ -23,7 +23,7 @@ import Servant.API.Modifiers -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer type Header = Header' '[Optional, Strict] -data Header' (mods :: [*]) (sym :: Symbol) a +data Header' (mods :: [*]) (sym :: Symbol) (a :: *) deriving Typeable -- $setup