Add cookbook entry for custom error formatters

.travis.yml

@@ -131,6 +131,7 @@ install:
     if ! $GHCJS ; then echo "packages: servant-pipes" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi
+    if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/custom-errors" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/db-postgres-pool" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/file-upload" >> cabal.project ; fi
@@ -165,6 +166,8 @@ install:
   - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-curl-mock' >> cabal.project ; fi
   - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-custom-errors' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-streaming' >> cabal.project ; fi
   - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-db-postgres-pool' >> cabal.project ; fi
@@ -190,7 +193,7 @@ install:
     echo "allow-newer:  servant-pagination-2.2.2:servant"        >> cabal.project
     echo "allow-newer:  servant-pagination-2.2.2:servant-server" >> cabal.project
     echo "optimization: False"                                   >> cabal.project
-  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
+  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-custom-errors|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
   - cat cabal.project || true
   - cat cabal.project.local || true
   - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
@@ -206,6 +209,7 @@ install:
   - if [ -f "servant-pipes/configure.ac" ]; then (cd "servant-pipes" && autoreconf -i); fi
   - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then (cd "doc/cookbook/basic-auth" && autoreconf -i); fi
   - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then (cd "doc/cookbook/curl-mock" && autoreconf -i); fi
+  - if [ -f "doc/cookbook/custom-errors/configure.ac" ]; then (cd "doc/cookbook/custom-errors" && autoreconf -i); fi
   - if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then (cd "doc/cookbook/basic-streaming" && autoreconf -i); fi
   - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then (cd "doc/cookbook/db-postgres-pool" && autoreconf -i); fi
   - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then (cd "doc/cookbook/file-upload" && autoreconf -i); fi
@@ -242,6 +246,7 @@ script:
   - PKGDIR_servant_pipes="$(find . -maxdepth 1 -type d -regex '.*/servant-pipes-[0-9.]*')"
   - PKGDIR_cookbook_basic_auth="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-auth-[0-9.]*')"
   - PKGDIR_cookbook_curl_mock="$(find . -maxdepth 1 -type d -regex '.*/cookbook-curl-mock-[0-9.]*')"
+  - PKGDIR_cookbook_custom_errors="$(find . -maxdepth 1 -type d -regex '.*/cookbook-custom-errors-[0-9.]*')"
   - PKGDIR_cookbook_basic_streaming="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-streaming-[0-9.]*')"
   - PKGDIR_cookbook_db_postgres_pool="$(find . -maxdepth 1 -type d -regex '.*/cookbook-db-postgres-pool-[0-9.]*')"
   - PKGDIR_cookbook_file_upload="$(find . -maxdepth 1 -type d -regex '.*/cookbook-file-upload-[0-9.]*')"
@@ -267,6 +272,7 @@ script:
     if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi
+    if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_custom_errors}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_db_postgres_pool}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_file_upload}" >> cabal.project ; fi
@@ -301,6 +307,8 @@ script:
   - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-curl-mock' >> cabal.project ; fi
   - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-custom-errors' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-streaming' >> cabal.project ; fi
   - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-db-postgres-pool' >> cabal.project ; fi
@@ -326,7 +334,7 @@ script:
     echo "allow-newer:  servant-pagination-2.2.2:servant"        >> cabal.project
     echo "allow-newer:  servant-pagination-2.2.2:servant-server" >> cabal.project
     echo "optimization: False"                                   >> cabal.project
-  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
+  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-custom-errors|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
   - cat cabal.project || true
   - cat cabal.project.local || true
   - |
@@ -345,6 +353,7 @@ script:
         servant-pipes) echo ${PKGDIR_servant_pipes} ;;
         cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;;
         cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;;
+        cookbook-custom-errors) echo ${PKGDIR_cookbook_custom_errors} ;;
         cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;;
         cookbook-db-postgres-pool) echo ${PKGDIR_cookbook_db_postgres_pool} ;;
         cookbook-file-upload) echo ${PKGDIR_cookbook_file_upload} ;;

cabal.project

@@ -22,6 +22,7 @@ packages:
 packages:
   doc/cookbook/basic-auth
   doc/cookbook/curl-mock
+  doc/cookbook/custom-errors
   doc/cookbook/basic-streaming
   doc/cookbook/db-postgres-pool
 --  doc/cookbook/db-sqlite-simple

doc/cookbook/custom-errors/CustomErrors.lhs

@@ -0,0 +1,189 @@
+# Customizing errors from Servant
+
+Servant handles a lot of parsing and validation of the input request. When it can't parse something: query
+parameters, URL parts or request body, it will return appropriate HTTP codes like 400 Bad Request.
+
+These responses will contain the error message in their body without any formatting. However, it is often
+desirable to be able to provide custom formatting for these error messages, for example, to wrap them in JSON.
+
+Recently Servant got a way to add such formatting. This Cookbook chapter demonstrates how to use it.
+
+Extensions and imports:
+```haskell
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PolyKinds         #-}
+{-# LANGUAGE TypeFamilies      #-}
+{-# LANGUAGE TypeOperators     #-}
+
+import           Data.Aeson
+import           Data.Proxy
+import           Data.Text
+import           GHC.Generics
+import           Network.Wai
+import           Network.Wai.Handler.Warp
+
+import           Servant
+
+import           Data.String.Conversions
+                 (cs)
+import           Servant.API.ContentTypes
+```
+
+The API (from `greet.hs` example in Servant sources):
+
+```haskell
+-- | A greet message data type
+newtype Greet = Greet { _msg :: Text }
+  deriving (Generic, Show)
+
+instance FromJSON Greet
+instance ToJSON Greet
+
+-- API specification
+type TestApi =
+       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
+       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
+
+       -- POST /greet with a Greet as JSON in the request body,
+       --             returns a Greet as JSON
+  :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet
+
+       -- DELETE /greet/:greetid
+  :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Server-side handlers.
+--
+-- There's one handler per endpoint, which, just like in the type
+-- that represents the API, are glued together using :<|>.
+--
+-- Each handler runs in the 'Handler' monad.
+server :: Server TestApi
+server = helloH :<|> postGreetH :<|> deleteGreetH
+
+  where helloH name Nothing = helloH name (Just False)
+        helloH name (Just False) = return . Greet $ "Hello, " <> name
+        helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
+
+        postGreetH greet = return greet
+
+        deleteGreetH _ = return NoContent
+```
+
+## Error formatters
+
+`servant-server` provides an `ErrorFormatter` type to specify how the error message will be
+formatted. A formatter is just a function accepting three parameters:
+
+- `TypeRep` from `Data.Typeable`: this is a runtime representation of the type of the combinator
+  (like `Capture` or `ReqBody`) that generated the error. It can be used to display its name (with
+  `show`) or even dynamically dispatch on the combinator type. See the docs for `Data.Typeable` and
+  `Type.Reflection` modules.
+- `Request`: full information for the request that led to the error.
+- `String`: specific error message from the combinator.
+
+The formatter is expected to produce a `ServerError` which will be returned from the handler.
+
+Additionally, there is `NotFoundErrorFormatter`, which accepts only `Request` and can customize the
+error in case when no route can be matched (HTTP 404).
+
+Let's make two formatters. First one will wrap our error in a JSON:
+
+```json
+{
+  "error": "ERROR MESSAGE",
+  "combinator": "NAME OF THE COMBINATOR"
+}
+```
+
+Additionally, this formatter will examine the `Accept` header of the request and generate JSON
+message only if client can accept it.
+
+```haskell
+customFormatter :: ErrorFormatter
+customFormatter tr req err =
+  let
+    -- aeson Value which will be sent to the client
+    value = object ["combinator" .= show tr, "error" .= err]
+    -- Accept header of the request
+    accH = getAcceptHeader req
+  in
+  -- handleAcceptH is Servant's function that checks whether the client can accept a
+  -- certain message type.
+  -- In this case we call it with "Proxy '[JSON]" argument, meaning that we want to return a JSON.
+  case handleAcceptH (Proxy :: Proxy '[JSON]) accH value of
+    -- If client can't handle JSON, we just return the body the old way
+    Nothing -> err400 { errBody = cs err }
+    -- Otherwise, we return the JSON formatted body and set the "Content-Type" header.
+    Just (ctypeH, body) -> err400
+      { errBody = body
+      , errHeaders = [("Content-Type", cs ctypeH)]
+      }
+
+notFoundFormatter :: NotFoundErrorFormatter
+notFoundFormatter req =
+  err404 { errBody = cs $ "Not found path: " <> rawPathInfo req }
+```
+
+If you don't need to react to the `Accept` header, you can just unconditionally return the JSON like
+this (with `encode` from `Data.Aeson`):
+
+```
+err400
+  { errBody = encode body
+  , errHeaders = [("Content-Type", "application/json")]
+  }
+```
+
+## Passing formatters to Servant
+
+Servant uses the Context to configure formatters. You only need to add a value of type
+`ErrorFormatters` to your context. This is a record with the following fields:
+
+- `bodyParserErrorFormatter :: ErrorFormatter`
+- `urlParseErrorFormatter :: ErrorFormatter`
+- `headerParseErrorFormatter :: ErrorFormatter`
+- `notFoundErrorFormatter :: NotFoundErrorFormatter`
+
+Default formatters are exported as `defaultErrorFormatters`, so you can use record update syntax to
+set the only ones you need:
+
+```haskell
+customFormatters :: ErrorFormatters
+customFormatters = defaultErrorFormatters
+  { bodyParserErrorFormatter = customFormatter
+  , notFoundErrorFormatter = notFoundFormatter
+  }
+```
+
+And at last, use `serveWithContext` to run your server as usual:
+
+```haskell
+app :: Application
+app = serveWithContext testApi (customFormatters :. EmptyContext) server
+
+main :: IO ()
+main = run 8000 app
+```
+
+Now if we try to request something with a wrong body, we will get a nice error:
+
+```
+$ http -j POST localhost:8000/greet 'foo=bar'
+HTTP/1.1 400 Bad Request
+Content-Type: application/json;charset=utf-8
+Date: Fri, 17 Jul 2020 13:34:18 GMT
+Server: Warp/3.3.12
+Transfer-Encoding: chunked
+
+{
+    "combinator": "ReqBody'",
+    "error": "Error in $: parsing Main.Greet(Greet) failed, key \"_msg\" not found"
+}
+```
+
+Notice the `Content-Type` header set by our combinator.

doc/cookbook/custom-errors/custom-errors.cabal

@@ -0,0 +1,25 @@
+name:                cookbook-custom-errors
+version:             0.1
+synopsis:            Return custom error messages from combinators
+homepage:            http://docs.servant.dev
+license:             BSD3
+license-file:        ../../../servant/LICENSE
+author:              Servant Contributors
+maintainer:          haskell-servant-maintainers@googlegroups.com
+build-type:          Simple
+cabal-version:       >=1.10
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3
+
+executable cookbook-custom-errors
+  main-is:             CustomErrors.lhs
+  build-depends:       base == 4.*
+                     , aeson
+                     , servant
+                     , servant-server
+                     , string-conversions
+                     , text
+                     , wai
+                     , warp
+  default-language:    Haskell2010
+  ghc-options:         -Wall -pgmL markdown-unlit
+  build-tool-depends: markdown-unlit:markdown-unlit

doc/cookbook/index.rst

@@ -25,6 +25,7 @@ you name it!
   db-postgres-pool/PostgresPool.lhs
   using-custom-monad/UsingCustomMonad.lhs
   using-free-client/UsingFreeClient.lhs
+  custom-errors/CustomErrors.lhs
   basic-auth/BasicAuth.lhs
   basic-streaming/Streaming.lhs
   jwt-and-basic-auth/JWTAndBasicAuth.lhs