Merge pull request #1312 from maksbotan/maksbotan/configurable-combinator-errors
Configurable combinator errors
This commit is contained in:
fisx
GitHub
commit
c5717a61a3
41 changed files with 650 additions and 121 deletions
128
.travis.yml
128
.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
|
||||
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"]}}
|
||||
- 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.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 (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 (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover) ; fi
|
||||
- if ! $GHCJS ; then ${CABAL} v2-install $WITHCOMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.16.3' ; 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 ${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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
189
doc/cookbook/custom-errors/CustomErrors.lhs
Normal file
189
doc/cookbook/custom-errors/CustomErrors.lhs
Normal file
|
|
@ -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.
|
||||
25
doc/cookbook/custom-errors/custom-errors.cabal
Normal file
25
doc/cookbook/custom-errors/custom-errors.cabal
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ module Servant.Server.Internal
|
|||
, module Servant.Server.Internal.Context
|
||||
, module Servant.Server.Internal.Delayed
|
||||
, module Servant.Server.Internal.DelayedIO
|
||||
, module Servant.Server.Internal.ErrorFormatter
|
||||
, module Servant.Server.Internal.Handler
|
||||
, module Servant.Server.Internal.Router
|
||||
, module Servant.Server.Internal.RouteResult
|
||||
|
|
@ -95,6 +96,7 @@ import Servant.Server.Internal.BasicAuth
|
|||
import Servant.Server.Internal.Context
|
||||
import Servant.Server.Internal.Delayed
|
||||
import Servant.Server.Internal.DelayedIO
|
||||
import Servant.Server.Internal.ErrorFormatter
|
||||
import Servant.Server.Internal.Handler
|
||||
import Servant.Server.Internal.Router
|
||||
import Servant.Server.Internal.RouteResult
|
||||
|
|
@ -168,7 +170,10 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont
|
|||
-- > server = getBook
|
||||
-- > where getBook :: Text -> Handler Book
|
||||
-- > getBook isbn = ...
|
||||
instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods))
|
||||
instance (KnownSymbol capture, FromHttpApiData a
|
||||
, HasServer api context, SBoolI (FoldLenient mods)
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
|
||||
)
|
||||
=> HasServer (Capture' mods capture a :> api) context where
|
||||
|
||||
type ServerT (Capture' mods capture a :> api) m =
|
||||
|
|
@ -180,12 +185,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
|
|||
CaptureRouter $
|
||||
route (Proxy :: Proxy api)
|
||||
context
|
||||
(addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods)
|
||||
, parseUrlPiece txt :: Either T.Text a) of
|
||||
(SFalse, Left e) -> delayedFail err400 { errBody = cs e }
|
||||
(SFalse, Right v) -> return v
|
||||
(STrue, piece) -> return $ (either (Left . cs) Right) piece
|
||||
)
|
||||
(addCapture d $ \ txt -> withRequest $ \ request ->
|
||||
case ( sbool :: SBool (FoldLenient mods)
|
||||
, parseUrlPiece txt :: Either T.Text a) of
|
||||
(SFalse, Left e) -> delayedFail $ formatError rep request $ cs e
|
||||
(SFalse, Right v) -> return v
|
||||
(STrue, piece) -> return $ (either (Left . cs) Right) piece)
|
||||
where
|
||||
rep = typeRep (Proxy :: Proxy Capture')
|
||||
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
|
||||
-- | If you use 'CaptureAll' in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a
|
||||
|
|
@ -204,7 +212,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI
|
|||
-- > server = getSourceFile
|
||||
-- > where getSourceFile :: [Text] -> Handler Book
|
||||
-- > getSourceFile pathSegments = ...
|
||||
instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
|
||||
instance (KnownSymbol capture, FromHttpApiData a
|
||||
, HasServer api context
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
|
||||
)
|
||||
=> HasServer (CaptureAll capture a :> api) context where
|
||||
|
||||
type ServerT (CaptureAll capture a :> api) m =
|
||||
|
|
@ -216,11 +227,14 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)
|
|||
CaptureAllRouter $
|
||||
route (Proxy :: Proxy api)
|
||||
context
|
||||
(addCapture d $ \ txts -> case parseUrlPieces txts of
|
||||
Left _ -> delayedFail err400
|
||||
Right v -> return v
|
||||
(addCapture d $ \ txts -> withRequest $ \ request ->
|
||||
case parseUrlPieces txts of
|
||||
Left e -> delayedFail $ formatError rep request $ cs e
|
||||
Right v -> return v
|
||||
)
|
||||
|
||||
where
|
||||
rep = typeRep (Proxy :: Proxy CaptureAll)
|
||||
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
|
||||
allowedMethodHead :: Method -> Request -> Bool
|
||||
allowedMethodHead method request = method == methodGet && requestMethod request == methodHead
|
||||
|
|
@ -240,10 +254,10 @@ methodCheck method request
|
|||
-- body check is no longer an option. However, we now run the accept
|
||||
-- check before the body check and can therefore afford to make it
|
||||
-- recoverable.
|
||||
acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()
|
||||
acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()
|
||||
acceptCheck proxy accH
|
||||
| canHandleAcceptH proxy (AcceptHeader accH) = return ()
|
||||
| otherwise = delayedFail err406
|
||||
| canHandleAcceptH proxy accH = return ()
|
||||
| otherwise = delayedFail err406
|
||||
|
||||
methodRouter :: (AllCTRender ctypes a)
|
||||
=> (b -> ([(HeaderName, B.ByteString)], a))
|
||||
|
|
@ -253,12 +267,12 @@ methodRouter :: (AllCTRender ctypes a)
|
|||
methodRouter splitHeaders method proxy status action = leafRouter route'
|
||||
where
|
||||
route' env request respond =
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
let accH = getAcceptHeader request
|
||||
in runAction (action `addMethodCheck` methodCheck method request
|
||||
`addAcceptCheck` acceptCheck proxy accH
|
||||
) env request respond $ \ output -> do
|
||||
let (headers, b) = splitHeaders output
|
||||
case handleAcceptH proxy (AcceptHeader accH) b of
|
||||
case handleAcceptH proxy accH b of
|
||||
Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
|
||||
Just (contentT, body) ->
|
||||
let bdy = if allowedMethodHead method request then "" else body
|
||||
|
|
@ -343,7 +357,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra
|
|||
-> Delayed env (Handler c)
|
||||
-> Router env
|
||||
streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
|
||||
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
|
||||
let AcceptHeader accH = getAcceptHeader request
|
||||
cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
|
||||
accCheck = when (isNothing cmediatype) $ delayedFail err406
|
||||
contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)
|
||||
|
|
@ -388,6 +402,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou
|
|||
instance
|
||||
(KnownSymbol sym, FromHttpApiData a, HasServer api context
|
||||
, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
|
||||
)
|
||||
=> HasServer (Header' mods sym a :> api) context where
|
||||
------
|
||||
|
|
@ -399,6 +414,9 @@ instance
|
|||
route Proxy context subserver = route (Proxy :: Proxy api) context $
|
||||
subserver `addHeaderCheck` withRequest headerCheck
|
||||
where
|
||||
rep = typeRep (Proxy :: Proxy Header')
|
||||
formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
|
||||
headerName :: IsString n => n
|
||||
headerName = fromString $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
|
|
@ -409,15 +427,13 @@ instance
|
|||
mev :: Maybe (Either T.Text a)
|
||||
mev = fmap parseHeader $ lookup headerName (requestHeaders req)
|
||||
|
||||
errReq = delayedFailFatal err400
|
||||
{ errBody = "Header " <> headerName <> " is required"
|
||||
}
|
||||
errReq = delayedFailFatal $ formatError rep req
|
||||
$ "Header " <> headerName <> " is required"
|
||||
|
||||
errSt e = delayedFailFatal err400
|
||||
{ errBody = cs $ "Error parsing header "
|
||||
<> headerName
|
||||
<> " failed: " <> e
|
||||
}
|
||||
errSt e = delayedFailFatal $ formatError rep req
|
||||
$ cs $ "Error parsing header "
|
||||
<> headerName
|
||||
<> " failed: " <> e
|
||||
|
||||
-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,
|
||||
-- this automatically requires your server-side handler to be a function
|
||||
|
|
@ -443,6 +459,7 @@ instance
|
|||
instance
|
||||
( KnownSymbol sym, FromHttpApiData a, HasServer api context
|
||||
, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
|
||||
)
|
||||
=> HasServer (QueryParam' mods sym a :> api) context where
|
||||
------
|
||||
|
|
@ -455,6 +472,9 @@ instance
|
|||
let querytext = queryToQueryText . queryString
|
||||
paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
rep = typeRep (Proxy :: Proxy QueryParam')
|
||||
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
|
||||
parseParam :: Request -> DelayedIO (RequestArgument mods a)
|
||||
parseParam req =
|
||||
unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev
|
||||
|
|
@ -462,14 +482,12 @@ instance
|
|||
mev :: Maybe (Either T.Text a)
|
||||
mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req
|
||||
|
||||
errReq = delayedFailFatal err400
|
||||
{ errBody = cs $ "Query parameter " <> paramname <> " is required"
|
||||
}
|
||||
errReq = delayedFailFatal $ formatError rep req
|
||||
$ cs $ "Query parameter " <> paramname <> " is required"
|
||||
|
||||
errSt e = delayedFailFatal err400
|
||||
{ errBody = cs $ "Error parsing query parameter "
|
||||
<> paramname <> " failed: " <> e
|
||||
}
|
||||
errSt e = delayedFailFatal $ formatError rep req
|
||||
$ cs $ "Error parsing query parameter "
|
||||
<> paramname <> " failed: " <> e
|
||||
|
||||
delayed = addParameterCheck subserver . withRequest $ \req ->
|
||||
parseParam req
|
||||
|
|
@ -495,7 +513,8 @@ instance
|
|||
-- > server = getBooksBy
|
||||
-- > where getBooksBy :: [Text] -> Handler [Book]
|
||||
-- > getBooksBy authors = ...return all books by these authors...
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
||||
instance (KnownSymbol sym, FromHttpApiData a, HasServer api context
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)
|
||||
=> HasServer (QueryParams sym a :> api) context where
|
||||
|
||||
type ServerT (QueryParams sym a :> api) m =
|
||||
|
|
@ -506,21 +525,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
|||
route Proxy context subserver = route (Proxy :: Proxy api) context $
|
||||
subserver `addParameterCheck` withRequest paramsCheck
|
||||
where
|
||||
rep = typeRep (Proxy :: Proxy QueryParams)
|
||||
formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
|
||||
paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
paramsCheck req =
|
||||
case partitionEithers $ fmap parseQueryParam params of
|
||||
([], parsed) -> return parsed
|
||||
(errs, _) -> delayedFailFatal err400
|
||||
{ errBody = cs $ "Error parsing query parameter(s) "
|
||||
<> paramname <> " failed: "
|
||||
<> T.intercalate ", " errs
|
||||
}
|
||||
(errs, _) -> delayedFailFatal $ formatError rep req
|
||||
$ cs $ "Error parsing query parameter(s) "
|
||||
<> paramname <> " failed: "
|
||||
<> T.intercalate ", " errs
|
||||
where
|
||||
params :: [T.Text]
|
||||
params = mapMaybe snd
|
||||
. filter (looksLikeParam . fst)
|
||||
. queryToQueryText
|
||||
. queryString
|
||||
. queryToQueryText
|
||||
. queryString
|
||||
$ req
|
||||
|
||||
looksLikeParam name = name == paramname || name == (paramname <> "[]")
|
||||
|
|
@ -588,7 +609,7 @@ instance HasServer Raw context where
|
|||
-- The @Content-Type@ header is inspected, and the list provided is used to
|
||||
-- attempt deserialization. If the request does not have a @Content-Type@
|
||||
-- header, it is treated as @application/octet-stream@ (as specified in
|
||||
-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.
|
||||
-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).
|
||||
-- This lets servant worry about extracting it from the request and turning
|
||||
-- it into a value of the type you specify.
|
||||
--
|
||||
|
|
@ -604,6 +625,7 @@ instance HasServer Raw context where
|
|||
-- > where postBook :: Book -> Handler Book
|
||||
-- > postBook book = ...insert into your db...
|
||||
instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)
|
||||
, HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters
|
||||
) => HasServer (ReqBody' mods list a :> api) context where
|
||||
|
||||
type ServerT (ReqBody' mods list a :> api) m =
|
||||
|
|
@ -615,6 +637,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
|
|||
= route (Proxy :: Proxy api) context $
|
||||
addBodyCheck subserver ctCheck bodyCheck
|
||||
where
|
||||
rep = typeRep (Proxy :: Proxy ReqBody')
|
||||
formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)
|
||||
|
||||
-- Content-Type check, we only lookup we can try to parse the request body
|
||||
ctCheck = withRequest $ \ request -> do
|
||||
-- See HTTP RFC 2616, section 7.2.1
|
||||
|
|
@ -633,7 +658,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods
|
|||
case sbool :: SBool (FoldLenient mods) of
|
||||
STrue -> return mrqbody
|
||||
SFalse -> case mrqbody of
|
||||
Left e -> delayedFailFatal err400 { errBody = cs e }
|
||||
Left e -> delayedFailFatal $ formatError rep request e
|
||||
Right v -> return v
|
||||
|
||||
instance
|
||||
|
|
@ -761,6 +786,9 @@ instance ( KnownSymbol realm
|
|||
ct_wildcard :: B.ByteString
|
||||
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
||||
|
||||
getAcceptHeader :: Request -> AcceptHeader
|
||||
getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders
|
||||
|
||||
-- * General Authentication
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Servant.Server.Internal.Context where
|
||||
|
||||
|
|
@ -45,6 +46,20 @@ instance Eq (Context '[]) where
|
|||
instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where
|
||||
x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2
|
||||
|
||||
-- | Append two type-level lists.
|
||||
--
|
||||
-- Hint: import it as
|
||||
--
|
||||
-- > import Servant.Server (type (.++))
|
||||
type family (.++) (l1 :: [*]) (l2 :: [*]) where
|
||||
'[] .++ a = a
|
||||
(a ': as) .++ b = a ': (as .++ b)
|
||||
|
||||
-- | Append two contexts.
|
||||
(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)
|
||||
EmptyContext .++ a = a
|
||||
(a :. as) .++ b = a :. (as .++ b)
|
||||
|
||||
-- | This class is used to access context entries in 'Context's. 'getContextEntry'
|
||||
-- returns the first value where the type matches:
|
||||
--
|
||||
|
|
|
|||
79
servant-server/src/Servant/Server/Internal/ErrorFormatter.hs
Normal file
79
servant-server/src/Servant/Server/Internal/ErrorFormatter.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -17,8 +17,9 @@ import Data.Text
|
|||
import qualified Data.Text as T
|
||||
import Network.Wai
|
||||
(Response, pathInfo)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ErrorFormatter
|
||||
import Servant.Server.Internal.RouteResult
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServerError
|
||||
|
||||
type Router env = Router' env RoutingApplication
|
||||
|
|
@ -153,52 +154,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env ->
|
|||
tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))
|
||||
|
||||
-- | Interpret a router as an application.
|
||||
runRouter :: Router () -> RoutingApplication
|
||||
runRouter r = runRouterEnv r ()
|
||||
runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication
|
||||
runRouter fmt r = runRouterEnv fmt r ()
|
||||
|
||||
runRouterEnv :: Router env -> env -> RoutingApplication
|
||||
runRouterEnv router env request respond =
|
||||
runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication
|
||||
runRouterEnv fmt router env request respond =
|
||||
case router of
|
||||
StaticRouter table ls ->
|
||||
case pathInfo request of
|
||||
[] -> runChoice ls env request respond
|
||||
[] -> runChoice fmt ls env request respond
|
||||
-- This case is to handle trailing slashes.
|
||||
[""] -> runChoice ls env request respond
|
||||
[""] -> runChoice fmt ls env request respond
|
||||
first : rest | Just router' <- M.lookup first table
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouterEnv router' env request' respond
|
||||
_ -> respond $ Fail err404
|
||||
in runRouterEnv fmt router' env request' respond
|
||||
_ -> respond $ Fail $ fmt request
|
||||
CaptureRouter router' ->
|
||||
case pathInfo request of
|
||||
[] -> respond $ Fail err404
|
||||
[] -> respond $ Fail $ fmt request
|
||||
-- This case is to handle trailing slashes.
|
||||
[""] -> respond $ Fail err404
|
||||
[""] -> respond $ Fail $ fmt request
|
||||
first : rest
|
||||
-> let request' = request { pathInfo = rest }
|
||||
in runRouterEnv router' (first, env) request' respond
|
||||
in runRouterEnv fmt router' (first, env) request' respond
|
||||
CaptureAllRouter router' ->
|
||||
let segments = pathInfo request
|
||||
request' = request { pathInfo = [] }
|
||||
in runRouterEnv router' (segments, env) request' respond
|
||||
in runRouterEnv fmt router' (segments, env) request' respond
|
||||
RawRouter app ->
|
||||
app env request respond
|
||||
Choice r1 r2 ->
|
||||
runChoice [runRouterEnv r1, runRouterEnv r2] env request respond
|
||||
runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond
|
||||
|
||||
-- | Try a list of routing applications in order.
|
||||
-- We stop as soon as one fails fatally or succeeds.
|
||||
-- If all fail normally, we pick the "best" error.
|
||||
--
|
||||
runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication
|
||||
runChoice ls =
|
||||
runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication
|
||||
runChoice fmt ls =
|
||||
case ls of
|
||||
[] -> \ _ _ respond -> respond (Fail err404)
|
||||
[] -> \ _ request respond -> respond (Fail $ fmt request)
|
||||
[r] -> r
|
||||
(r : rs) ->
|
||||
\ env request respond ->
|
||||
r env request $ \ response1 ->
|
||||
case response1 of
|
||||
Fail _ -> runChoice rs env request $ \ response2 ->
|
||||
Fail _ -> runChoice fmt rs env request $ \ response2 ->
|
||||
respond $ highestPri response1 response2
|
||||
_ -> respond response1
|
||||
where
|
||||
|
|
|
|||
|
|
@ -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 {{{
|
||||
|
|
|
|||
|
|
@ -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 $
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue