diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ------ diff --git a/servant-server.cabal b/servant-server.cabal --- a/servant-server.cabal +++ b/servant-server.cabal @@ -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 diff --git a/src/Servant/Server.hs b/src/Servant/Server.hs --- a/src/Servant/Server.hs +++ b/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 @@ -- * 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. -- diff --git a/src/Servant/Server/Generic.hs b/src/Servant/Server/Generic.hs --- a/src/Servant/Server/Generic.hs +++ b/src/Servant/Server/Generic.hs @@ -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 +-- . genericServerT :: GenericServant routes (AsServerT m) => routes (AsServerT m) diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs --- a/src/Servant/Server/Internal.hs +++ b/src/Servant/Server/Internal.hs @@ -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 --- . +-- [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 diff --git a/src/Servant/Server/Internal/BasicAuth.hs b/src/Servant/Server/Internal/BasicAuth.hs --- a/src/Servant/Server/Internal/BasicAuth.hs +++ b/src/Servant/Server/Internal/BasicAuth.hs @@ -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 diff --git a/src/Servant/Server/Internal/Context.hs b/src/Servant/Server/Internal/Context.hs --- a/src/Servant/Server/Internal/Context.hs +++ b/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 @@ -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: diff --git a/src/Servant/Server/Internal/Delayed.hs b/src/Servant/Server/Internal/Delayed.hs --- a/src/Servant/Server/Internal/Delayed.hs +++ b/src/Servant/Server/Internal/Delayed.hs @@ -268,5 +268,5 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Due to GHC issue , 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. -} diff --git a/src/Servant/Server/Internal/DelayedIO.hs b/src/Servant/Server/Internal/DelayedIO.hs --- a/src/Servant/Server/Internal/DelayedIO.hs +++ b/src/Servant/Server/Internal/DelayedIO.hs @@ -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 } diff --git a/src/Servant/Server/Internal/ErrorFormatter.hs b/src/Servant/Server/Internal/ErrorFormatter.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Server/Internal/ErrorFormatter.hs @@ -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 diff --git a/src/Servant/Server/Internal/Router.hs b/src/Servant/Server/Internal/Router.hs --- a/src/Servant/Server/Internal/Router.hs +++ b/src/Servant/Server/Internal/Router.hs @@ -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 diff --git a/test/Servant/Server/ErrorSpec.hs b/test/Servant/Server/ErrorSpec.hs --- a/test/Servant/Server/ErrorSpec.hs +++ b/test/Servant/Server/ErrorSpec.hs @@ -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 -- }}} ------------------------------------------------------------------------------ diff --git a/test/Servant/Server/RouterSpec.hs b/test/Servant/Server/RouterSpec.hs --- a/test/Servant/Server/RouterSpec.hs +++ b/test/Servant/Server/RouterSpec.hs @@ -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 $