summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthiasFischmann <>2020-07-31 18:29:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-07-31 18:29:00 (GMT)
commit105b40dc49fa4d00fdb01efad0247951a1ec0982 (patch)
treef25031f72fb0e6c50d7af05184a2acba539a4f2b
parentceff69744d5e8647d834ceddc36ac8143f6633e1 (diff)
version 0.18HEAD0.18master
-rwxr-xr-xCHANGELOG.md15
-rw-r--r--servant-server.cabal20
-rw-r--r--src/Servant/Server.hs32
-rw-r--r--src/Servant/Server/Generic.hs9
-rw-r--r--src/Servant/Server/Internal.hs116
-rw-r--r--src/Servant/Server/Internal/BasicAuth.hs2
-rw-r--r--src/Servant/Server/Internal/Context.hs33
-rw-r--r--src/Servant/Server/Internal/Delayed.hs2
-rw-r--r--src/Servant/Server/Internal/DelayedIO.hs2
-rw-r--r--src/Servant/Server/Internal/ErrorFormatter.hs87
-rw-r--r--src/Servant/Server/Internal/Router.hs37
-rw-r--r--test/Servant/Server/ErrorSpec.hs58
-rw-r--r--test/Servant/Server/RouterSpec.hs4
13 files changed, 326 insertions, 91 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 436a966..4468076 100755
--- 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
index bcd8c43..5f7268d 100644
--- 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 @@ tested-with:
|| ==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 @@ 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
@@ -63,7 +65,7 @@ library
-- 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 @@ library
-- 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 @@ executable greet
, 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 @@ test-suite spec
, 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
index e2d9f3c..99c0b1e 100644
--- 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 @@ 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/src/Servant/Server/Generic.hs b/src/Servant/Server/Generic.hs
index c3a2e3b..c3db01c 100644
--- a/src/Servant/Server/Generic.hs
+++ b/src/Servant/Server/Generic.hs
@@ -31,7 +31,7 @@ instance GenericMode (AsServerT m) where
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 @@ 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'
@@ -80,13 +81,17 @@ genericServeTWithContext f server ctx =
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)
diff --git a/src/Servant/Server/Internal.hs b/src/Servant/Server/Internal.hs
index f1a24a1..9fa0187 100644
--- a/src/Servant/Server/Internal.hs
+++ b/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
--- <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
@@ -808,7 +836,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
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
index 8b5e06a..b92e4b0 100644
--- a/src/Servant/Server/Internal/BasicAuth.hs
+++ b/src/Servant/Server/Internal/BasicAuth.hs
@@ -32,7 +32,7 @@ import Servant.Server.Internal.ServerError
-- * 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
index 45a7276..cb4c23b 100644
--- 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 @@ import GHC.TypeLits
--
-- 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
@@ -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/src/Servant/Server/Internal/Delayed.hs b/src/Servant/Server/Internal/Delayed.hs
index 1e580cf..3ba8957 100644
--- a/src/Servant/Server/Internal/Delayed.hs
+++ b/src/Servant/Server/Internal/Delayed.hs
@@ -268,5 +268,5 @@ runAction action env req respond k = runResourceT $
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
-}
diff --git a/src/Servant/Server/Internal/DelayedIO.hs b/src/Servant/Server/Internal/DelayedIO.hs
index 48f35b9..6aaa23a 100644
--- a/src/Servant/Server/Internal/DelayedIO.hs
+++ b/src/Servant/Server/Internal/DelayedIO.hs
@@ -24,7 +24,7 @@ import Servant.Server.Internal.ServerError
-- | 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
index 0000000..26a7e85
--- /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
index d6735c9..ecee590 100644
--- a/src/Servant/Server/Internal/Router.hs
+++ b/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/test/Servant/Server/ErrorSpec.hs b/test/Servant/Server/ErrorSpec.hs
index 8da38bf..72251b2 100644
--- a/test/Servant/Server/ErrorSpec.hs
+++ b/test/Servant/Server/ErrorSpec.hs
@@ -15,6 +15,8 @@ import qualified Data.ByteString.Lazy.Char8 as BCL
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 @@ spec = describe "HTTP Errors" $ do
prioErrorsSpec
errorRetrySpec
errorChoiceSpec
+ customFormattersSpec
-- * Auth machinery (reused throughout)
@@ -295,6 +298,61 @@ errorChoiceSpec = describe "Multiple handlers return errors"
-- }}}
------------------------------------------------------------------------------
+-- * 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
+
+-- }}}
+------------------------------------------------------------------------------
-- * Instances {{{
instance MimeUnrender PlainText Int where
diff --git a/test/Servant/Server/RouterSpec.hs b/test/Servant/Server/RouterSpec.hs
index 472dfec..9b69a2e 100644
--- a/test/Servant/Server/RouterSpec.hs
+++ b/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 $