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

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

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.
 --

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'

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)
+              (addCapture d $ \ txt -> withRequest $ \ request ->
-                                            , parseUrlPiece txt :: Either T.Text a) of
+                case ( sbool :: SBool (FoldLenient mods)
-                 (SFalse, Left e) -> delayedFail err400 { errBody = cs e }
+                     , parseUrlPiece txt :: Either T.Text a) of
-                 (SFalse, Right v) -> return v
+                  (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
-                 (STrue, piece) -> return $ (either (Left . cs) Right) piece
+                  (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
+              (addCapture d $ \ txts -> withRequest $ \ request ->
-                 Left _  -> delayedFail err400
+                case parseUrlPieces txts of
-                 Right v -> return v
+                   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 ()
+  | canHandleAcceptH proxy accH = return ()
-  | otherwise                                  = delayedFail err406
+  | 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
+          errReq = delayedFailFatal $ formatError rep req
-            { errBody = "Header " <> headerName <> " is required"
+            $ "Header " <> headerName <> " is required"
-            }
 
-          errSt e = delayedFailFatal err400
+          errSt e = delayedFailFatal $ formatError rep req
-              { errBody = cs $ "Error parsing header "
+            $ cs $ "Error parsing header "
-                               <> headerName
+                    <> headerName
-                               <> " failed: " <> e
+                    <> " 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
+            errReq = delayedFailFatal $ formatError rep req
-              { errBody = cs $ "Query parameter " <> paramname <> " is required"
+              $ cs $ "Query parameter " <> paramname <> " is required"
-              }
 
-            errSt e = delayedFailFatal err400
+            errSt e = delayedFailFatal $ formatError rep req
-              { errBody = cs $ "Error parsing query parameter "
+              $ cs $ "Error parsing query parameter "
-                               <> paramname <> " failed: " <> e
+                      <> 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
+              (errs, _)    -> delayedFailFatal $ formatError rep req
-                  { errBody = cs $ "Error parsing query parameter(s) "
+                  $ cs $ "Error parsing query parameter(s) "
-                                   <> paramname <> " failed: "
+                         <> paramname <> " failed: "
-                                   <> T.intercalate ", " errs
+                         <> T.intercalate ", " errs
-                  }
         where
           params :: [T.Text]
           params = mapMaybe snd
                  . filter (looksLikeParam . fst)
-                 . queryToQueryText 
+                 . queryToQueryText
-                 . queryString                 
+                 . 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
 
 

servant-server/src/Servant/Server/Internal/Context.hs

@@ -1,11 +1,12 @@
-{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE KindSignatures        #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
-{-# LANGUAGE TypeOperators              #-}
+{-# 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:
 --

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

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 :: NotFoundErrorFormatter -> Router () -> RoutingApplication
-runRouter r = runRouterEnv r ()
+runRouter fmt r = runRouterEnv fmt r ()
 
-runRouterEnv :: Router env -> env -> RoutingApplication
+runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
-runRouterEnv router env request respond =
+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
+             in  runRouterEnv fmt router' env request' respond
-        _ -> respond $ Fail err404
+        _ -> 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 :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication
-runChoice ls =
+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

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 $

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