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
This commit is contained in:
Maxim Koltsov
parent
1f1f7f309a
commit
57f0b0b390
9 changed files with 228 additions and 75 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
-- <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 @@ 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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
--
|
||||
|
|
|
|||
79
servant-server/src/Servant/Server/Internal/ErrorFormatter.hs
Normal file
79
servant-server/src/Servant/Server/Internal/ErrorFormatter.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue