Merge pull request #1312 from maksbotan/maksbotan/configurable-combinator-errors

Configurable combinator errors

.travis.yml

@@ -2,9 +2,13 @@
 #
 #   haskell-ci '--config=cabal.haskell-ci' '--output=.travis.yml' 'cabal.project'
 #
+# To regenerate the script (for example after adjusting tested-with) run
+#
+#   haskell-ci regenerate
+#
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.9.20200121
+# version: 0.10.1
 #
 version: ~> 1.0
 language: c
@@ -40,20 +44,20 @@ jobs:
     - compiler: ghc-8.10.1
       addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}}
       os: linux
-    - compiler: ghc-8.8.2
+    - compiler: ghc-8.8.3
-      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.2","cabal-install-3.0"]}}
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}}
       os: linux
     - compiler: ghc-8.6.5
-      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}}
       os: linux
     - compiler: ghc-8.4.4
-      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}}
       os: linux
     - compiler: ghc-8.2.2
-      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}}
       os: linux
     - compiler: ghc-8.0.2
-      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
+      addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}}
       os: linux
 before_install:
   - |
@@ -110,9 +114,9 @@ install:
   - cat $CABALHOME/config
   - rm -fv cabal.project cabal.project.local cabal.project.freeze
   - travis_retry ${CABAL} v2-update -v
-  - if ! $GHCJS ; then (cd /tmp && ${CABAL} v2-install $WITHCOMPILER -j2 doctest --constraint='doctest ==0.16.3.*') ; fi
+  - if ! $GHCJS ; then ${CABAL} v2-install $WITHCOMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.16.3' ; fi
-  - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe') ; fi
+  - if $GHCJS ; then ${CABAL} v2-install -w ghc-8.4.4 --ignore-project cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe' ; fi
-  - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover) ; fi
+  - if $GHCJS ; then ${CABAL} v2-install -w ghc-8.4.4 --ignore-project hspec-discover ; fi
   # Generate cabal.project
   - rm -rf cabal.project cabal.project.local cabal.project.freeze
   - touch cabal.project
@@ -130,15 +134,59 @@ 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
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/generic" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/pagination" >> cabal.project ; fi
-    if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/testing" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/structuring-apis" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-custom-monad" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-free-client" >> cabal.project ; fi
+  - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant' >> cabal.project ; fi
+  - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client-core' >> cabal.project ; fi
+  - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-http-streams' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-docs' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-foreign' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-server' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package tutorial' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-machines' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-conduit' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-pipes' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-auth' >> 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-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
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-file-upload' >> 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-generic' >> 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-pagination' >> 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-structuring-apis' >> 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-using-custom-monad' >> 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-using-free-client' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - |
     echo "constraints:  foundation >=0.0.14"                     >> cabal.project
     echo "constraints:  memory <0.14.12 || >0.14.12"             >> cabal.project
@@ -148,7 +196,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-testing|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
@@ -164,12 +212,12 @@ 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
   - if [ -f "doc/cookbook/generic/configure.ac" ]; then (cd "doc/cookbook/generic" && autoreconf -i); fi
   - if [ -f "doc/cookbook/pagination/configure.ac" ]; then (cd "doc/cookbook/pagination" && autoreconf -i); fi
-  - if [ -f "doc/cookbook/testing/configure.ac" ]; then (cd "doc/cookbook/testing" && autoreconf -i); fi
   - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi
   - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi
   - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi
@@ -201,12 +249,12 @@ 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.]*')"
   - PKGDIR_cookbook_generic="$(find . -maxdepth 1 -type d -regex '.*/cookbook-generic-[0-9.]*')"
   - PKGDIR_cookbook_pagination="$(find . -maxdepth 1 -type d -regex '.*/cookbook-pagination-[0-9.]*')"
-  - PKGDIR_cookbook_testing="$(find . -maxdepth 1 -type d -regex '.*/cookbook-testing-[0-9.]*')"
   - PKGDIR_cookbook_structuring_apis="$(find . -maxdepth 1 -type d -regex '.*/cookbook-structuring-apis-[0-9.]*')"
   - PKGDIR_cookbook_using_custom_monad="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-custom-monad-[0-9.]*')"
   - PKGDIR_cookbook_using_free_client="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-free-client-[0-9.]*')"
@@ -227,15 +275,59 @@ 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
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_generic}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_pagination}" >> cabal.project ; fi
-    if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_testing}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_structuring_apis}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_custom_monad}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_free_client}" >> cabal.project ; fi
+  - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant' >> cabal.project ; fi
+  - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client-core' >> cabal.project ; fi
+  - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-http-streams' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-docs' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-foreign' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-server' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package tutorial' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-machines' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-conduit' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-pipes' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-auth' >> 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-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
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-file-upload' >> 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-generic' >> 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-pagination' >> 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-structuring-apis' >> 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-using-custom-monad' >> 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-using-free-client' >> cabal.project ; fi
+  - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
   - |
     echo "constraints:  foundation >=0.0.14"                     >> cabal.project
     echo "constraints:  memory <0.14.12 || >0.14.12"             >> cabal.project
@@ -245,7 +337,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-testing|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
   - |
@@ -264,12 +356,12 @@ 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} ;;
         cookbook-generic) echo ${PKGDIR_cookbook_generic} ;;
         cookbook-pagination) echo ${PKGDIR_cookbook_pagination} ;;
-        cookbook-testing) echo ${PKGDIR_cookbook_testing} ;;
         cookbook-structuring-apis) echo ${PKGDIR_cookbook_structuring_apis} ;;
         cookbook-using-custom-monad) echo ${PKGDIR_cookbook_using_custom_monad} ;;
         cookbook-using-free-client) echo ${PKGDIR_cookbook_using_free_client} ;;
@@ -303,5 +395,5 @@ script:
   - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi
   - echo -en 'travis_fold:end:haddock\\r'
 
-# REGENDATA ("0.9.20200121",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"])
+# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"])
 # EOF

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
@@ -32,7 +33,7 @@ packages:
   -- doc/cookbook/jwt-and-basic-auth/
   doc/cookbook/pagination
   -- doc/cookbook/sentry
-  doc/cookbook/testing
+--  doc/cookbook/testing
   doc/cookbook/structuring-apis
   doc/cookbook/using-custom-monad
   doc/cookbook/using-free-client

doc/cookbook/basic-auth/basic-auth.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-basic-auth
   main-is:             BasicAuth.lhs

doc/cookbook/basic-streaming/basic-streaming.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-basic-streaming
   main-is:             Streaming.lhs

doc/cookbook/curl-mock/curl-mock.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbock-curl-mock
   main-is:             CurlMock.lhs

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, GHC ==8.10.1
+
+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/db-postgres-pool/db-postgres-pool.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-db-postgres-pool
   main-is:             PostgresPool.lhs

doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-db-sqlite-simple
   main-is:             DBConnection.lhs

doc/cookbook/file-upload/file-upload.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-file-upload
   main-is:             FileUpload.lhs

doc/cookbook/generic/generic.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-using-custom-monad
   main-is:             Generic.lhs

doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal

@@ -11,7 +11,7 @@ maintainer:          haskell-servant-maintainers@googlegroups.com
 category:            Servant
 build-type:          Simple
 cabal-version:       >=1.10
-tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-hoist-server-with-context
   main-is:             HoistServerWithContext.lhs

doc/cookbook/https/https.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-https
   main-is:             Https.lhs

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

doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal

@@ -11,7 +11,7 @@ maintainer:          haskell-servant-maintainers@googlegroups.com
 category:            Servant
 build-type:          Simple
 cabal-version:       >=1.10
-tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-jwt-and-basic-auth
   main-is:             JWTAndBasicAuth.lhs

doc/cookbook/pagination/pagination.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-pagination
   main-is:             Pagination.lhs

doc/cookbook/sentry/sentry.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-sentry
   main-is:             Sentry.lhs

doc/cookbook/structuring-apis/structuring-apis.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-structuring-apis
   main-is:             StructuringApis.lhs

doc/cookbook/testing/testing.cabal

@@ -10,7 +10,7 @@ maintainer:          haskell-servant-maintainers@googlegroups.com
 category:            Servant
 build-type:          Simple
 cabal-version:       >=1.10
-tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-testing
   main-is:             Testing.lhs

doc/cookbook/using-custom-monad/using-custom-monad.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-using-custom-monad
   main-is:             UsingCustomMonad.lhs

doc/cookbook/using-free-client/using-free-client.cabal

@@ -8,7 +8,7 @@ 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.2
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1
 
 executable cookbook-using-free-client
   main-is:             UsingFreeClient.lhs

doc/tutorial/tutorial.cabal

@@ -17,7 +17,7 @@ tested-with:
   GHC==8.2.2
   GHC==8.4.4
   GHC==8.6.5
-  GHC==8.8.2
+  GHC==8.8.3, GHC ==8.10.1
 extra-source-files:
   static/index.html
   static/ui.js

servant-client-core/servant-client-core.cabal

@@ -21,7 +21,8 @@ tested-with:
    || ==8.2.2
    || ==8.4.4
    || ==8.6.5
-   || ==8.8.2
+   || ==8.8.3
+   || ==8.10.1
   , GHCJS == 8.4
 
 extra-source-files:

servant-client/servant-client.cabal

@@ -25,7 +25,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

servant-conduit/servant-conduit.cabal

@@ -22,7 +22,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

servant-docs/servant-docs.cabal

@@ -24,7 +24,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

servant-foreign/servant-foreign.cabal

@@ -26,7 +26,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

servant-http-streams/servant-http-streams.cabal

@@ -25,7 +25,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

servant-machines/servant-machines.cabal

@@ -22,7 +22,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

servant-pipes/servant-pipes.cabal

@@ -22,7 +22,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

servant-server/servant-server.cabal

@@ -29,7 +29,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
@@ -50,9 +51,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,15 +525,17 @@ 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
@@ -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/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)
 
@@ -293,6 +296,61 @@ errorChoiceSpec = describe "Multiple handlers return errors"
       `shouldRespondWith` 415
 
 
+-- }}}
+------------------------------------------------------------------------------
+-- * 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 {{{

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/servant.cabal

@@ -25,7 +25,8 @@ tested-with:
    || ==8.2.2
    || ==8.4.4
    || ==8.6.5
-   || ==8.8.2
+   || ==8.8.3
+   || ==8.10.1
   , GHCJS == 8.4
 
 extra-source-files:

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