servant-server 0.17 → 0.18
raw patch · 13 files changed
+326/−91 lines, 13 filesdep ~aesondep ~basedep ~base64-bytestringnew-uploader
Dependency ranges changed: aeson, base, base64-bytestring, servant
Files
- CHANGELOG.md +13/−2
- servant-server.cabal +11/−9
- src/Servant/Server.hs +30/−2
- src/Servant/Server/Generic.hs +7/−2
- src/Servant/Server/Internal.hs +72/−44
- src/Servant/Server/Internal/BasicAuth.hs +1/−1
- src/Servant/Server/Internal/Context.hs +24/−9
- src/Servant/Server/Internal/Delayed.hs +1/−1
- src/Servant/Server/Internal/DelayedIO.hs +1/−1
- src/Servant/Server/Internal/ErrorFormatter.hs +87/−0
- src/Servant/Server/Internal/Router.hs +19/−18
- test/Servant/Server/ErrorSpec.hs +58/−0
- test/Servant/Server/RouterSpec.hs +2/−2
CHANGELOG.md view
@@ -1,6 +1,17 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.18+----++### Significant changes++- Support for ghc8.8 (#1318, #1326, #1327)++- Configurable error messages for automatic errors thrown by servant,+ like "no route" or "could not parse json body" (#1312, #1326, #1327)++ 0.17 ---- @@ -35,7 +46,7 @@ Some APIs need query parameters rewriting, e.g. in order to support for multiple casing (camel, snake, etc) or something to that effect. - This could be easily achieved by using WAI Middleware and modyfing+ This could be easily achieved by using WAI Middleware and modifying request's `Query`. But QueryParam, QueryParams and QueryFlag use `rawQueryString`. By using `queryString` rather then `rawQueryString` we can enable such rewritings.@@ -44,7 +55,7 @@ We used `build-type: Custom`, but it's problematic e.g. for cross-compiling. The benefit is small, as the doctests- can be run other ways too (though not so conviniently).+ can be run other ways too (though not so conveniently). 0.16.2 ------
servant-server.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-server-version: 0.17+version: 0.18 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web@@ -28,7 +28,8 @@ || ==8.2.2 || ==8.4.4 || ==8.6.5- || ==8.8.2+ || ==8.8.3+ || ==8.10.1 extra-source-files: CHANGELOG.md@@ -49,9 +50,10 @@ 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@@ -63,7 +65,7 @@ -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends:- base >= 4.9 && < 4.14+ base >= 4.9 && < 4.15 , bytestring >= 0.10.8.1 && < 0.11 , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3@@ -74,14 +76,14 @@ -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends:- servant >= 0.16 && < 0.17.1+ servant >= 0.18 && < 0.19.1 , http-api-data >= 0.4.1 && < 0.4.2 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.12- , base64-bytestring >= 1.0.0.1 && < 1.1+ , base64-bytestring >= 1.0.0.1 && < 1.2 , exceptions >= 0.10.0 && < 0.11 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13@@ -114,7 +116,7 @@ , text build-depends:- aeson >= 1.4.1.0 && < 1.5+ aeson >= 1.4.1.0 && < 1.6 , warp >= 3.2.25 && < 3.4 test-suite spec@@ -154,9 +156,9 @@ , transformers-compat , wai - -- Additonal dependencies+ -- Additional dependencies build-depends:- aeson >= 1.4.1.0 && < 1.5+ aeson >= 1.4.1.0 && < 1.6 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.8 , hspec-wai >= 0.10.1 && < 0.11
src/Servant/Server.hs view
@@ -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 @@ -- * Context , Context(..) , HasContextEntry(getContextEntry)+ , type (.++)+ , (.++) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext@@ -86,6 +89,24 @@ , 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 @@ 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. --
src/Servant/Server/Generic.hs view
@@ -31,7 +31,7 @@ type AsServer = AsServerT Handler --- | Transform record of routes into a WAI 'Application'.+-- | Transform a record of routes into a WAI 'Application'. genericServe :: forall routes. ( HasServer (ToServantApi routes) '[]@@ -67,6 +67,7 @@ ( 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'@@ -80,13 +81,17 @@ p = genericApi (Proxy :: Proxy routes) pctx = Proxy :: Proxy ctx --- | Transform record of endpoints into a 'Server'.+-- | Transform a record of endpoints into a 'Server'. genericServer :: GenericServant routes AsServer => routes AsServer -> ToServant routes AsServer genericServer = toServant +-- | Transform a record of endpoints into a @'ServerT' m@.+--+-- You can see an example usage of this function+-- <https://docs.servant.dev/en/stable/cookbook/generic/Generic.html#using-generics-together-with-a-custom-monad in the Servant Cookbook>. genericServerT :: GenericServant routes (AsServerT m) => routes (AsServerT m)
src/Servant/Server/Internal.hs view
@@ -24,6 +24,7 @@ , 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.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 @@ -- > 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 @@ 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 @@ -- > 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 @@ 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 @@ -- 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 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 @@ -> 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 @@ 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 @@ 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 @@ 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 ( 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 @@ 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 @@ 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 @@ -- > 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 @@ 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 @@ -- 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--- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.+-- [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 @@ -- > 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 @@ = 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 @@ 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 @@ ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP +getAcceptHeader :: Request -> AcceptHeader+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders+ -- * General Authentication @@ -808,7 +836,7 @@ instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context where type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)- -- it doens't really matter what sub route we peak+ -- it doesn't really matter what sub route we peak route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" hoistServerWithContext _ _ _ = id
src/Servant/Server/Internal/BasicAuth.hs view
@@ -32,7 +32,7 @@ -- * Basic Auth -- | servant-server's current implementation of basic authentication is not--- immune to certian kinds of timing attacks. Decoding payloads does not take+-- immune to certain kinds of timing attacks. Decoding payloads does not take -- a fixed amount of time. -- | The result of authentication/authorization
src/Servant/Server/Internal/Context.hs view
@@ -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 @@ -20,7 +21,7 @@ -- -- If you are using combinators that require a non-empty 'Context' you have to -- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all--- the values your combinators need. A 'Context' is essentially a heterogenous+-- the values your combinators need. A 'Context' is essentially a heterogeneous -- list and accessing the elements is being done by type (see 'getContextEntry'). -- The parameter of the type 'Context' is a type-level list reflecting the types -- of the contained context entries. To create a 'Context' with entries, use the@@ -44,6 +45,20 @@ _ == _ = True 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:
src/Servant/Server/Internal/Delayed.hs view
@@ -268,5 +268,5 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot-do the more succint thing - just update the records we actually change.+do the more succinct thing - just update the records we actually change. -}
src/Servant/Server/Internal/DelayedIO.hs view
@@ -24,7 +24,7 @@ -- | Computations used in a 'Delayed' can depend on the -- incoming 'Request', may perform 'IO', and result in a--- 'RouteResult', meaning they can either suceed, fail+-- 'RouteResult', meaning they can either succeed, fail -- (with the possibility to recover), or fail fatally. -- newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a }
+ src/Servant/Server/Internal/ErrorFormatter.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Server.Internal.ErrorFormatter+ ( ErrorFormatters(..)+ , ErrorFormatter+ , NotFoundErrorFormatter++ , DefaultErrorFormatters+ , defaultErrorFormatters++ , MkContextWithErrorFormatter+ , mkContextWithErrorFormatter+ ) 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 = Proxy+_C :: Proxy Capture+_C = Proxy+_CT :: Proxy Context+_CT = Proxy
src/Servant/Server/Internal/Router.hs view
@@ -17,8 +17,9 @@ 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 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
test/Servant/Server/ErrorSpec.hs view
@@ -15,6 +15,8 @@ import Data.Monoid ((<>)) import Data.Proxy+import Data.String.Conversions+ (cs) import Network.HTTP.Types (hAccept, hAuthorization, hContentType, methodGet, methodPost, methodPut)@@ -31,6 +33,7 @@ prioErrorsSpec errorRetrySpec errorChoiceSpec+ customFormattersSpec -- * Auth machinery (reused throughout) @@ -292,6 +295,61 @@ request methodPost "path5" [(hContentType, "application/not-supported")] "" `shouldRespondWith` 415 ++-- }}}+------------------------------------------------------------------------------+-- * Custom errors {{{++customFormatter :: ErrorFormatter+customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs err }++customFormatters :: ErrorFormatters+customFormatters = defaultErrorFormatters+ { bodyParserErrorFormatter = customFormatter+ , urlParseErrorFormatter = customFormatter+ , notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" }+ }++type CustomFormatterAPI+ = "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String+ :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String+ :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String++customFormatterAPI :: Proxy CustomFormatterAPI+customFormatterAPI = Proxy++customFormatterServer :: Server CustomFormatterAPI+customFormatterServer = (\_ -> return "query")+ :<|> (\_ -> return "capture")+ :<|> (\_ -> return "body")++customFormattersSpec :: Spec+customFormattersSpec = describe "Custom errors from combinators"+ $ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do++ let startsWithCustom = ResponseMatcher+ { matchStatus = 400+ , matchHeaders = []+ , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BCL.isPrefixOf` body+ then Nothing+ else Just $ show body <> " does not start with \"CUSTOM!\""+ }++ it "formats query parse error" $ do+ request methodGet "query?param=false" [] ""+ `shouldRespondWith` startsWithCustom++ it "formats query parse error with missing param" $ do+ request methodGet "query" [] ""+ `shouldRespondWith` startsWithCustom++ it "formats capture parse error" $ do+ request methodGet "capture/42" [] ""+ `shouldRespondWith` startsWithCustom++ it "formats body parse error" $ do+ request methodPost "body" [(hContentType, "application/json")] "foo"+ `shouldRespondWith` startsWithCustom -- }}} ------------------------------------------------------------------------------
test/Servant/Server/RouterSpec.hs view
@@ -32,7 +32,7 @@ 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 @@ describe "runRouter" $ do let toApp :: Router () -> Application- toApp = toApplication . runRouter+ toApp = toApplication . runRouter (const err404) cap :: Router () cap = CaptureRouter $