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