c5717a6 · typeable/servant

git.iko.soy/typeable/servant

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

Configurable combinator errors

commitc5717a61a3ea103dd7445efa1ee0447a8d8330c4 authorfisx <mf@zerobuzz.net> dateThu 30 Jul 2020, 17:15 (6 years ago) parent4a6db6e cb0224d

41 files changed+650−121

compare with master

unifiedsplit

.travis.yml+110−18

@@ -2,9 +2,13 @@

22#

33# haskell-ci '--config=cabal.haskell-ci' '--output=.travis.yml' 'cabal.project'

44#

5+# To regenerate the script (for example after adjusting tested-with) run

6+#

7+# haskell-ci regenerate

8+#

59# For more information, see https://github.com/haskell-CI/haskell-ci

610#

7−# version: 0.9.20200121

11+# version: 0.10.1

812#

913version: ~> 1.0

1014language: c

@@ -40,20 +44,20 @@ jobs:

4044 - compiler: ghc-8.10.1

4145 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"]}}

4246 os: linux

43− - compiler: ghc-8.8.2

44− 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"]}}

47+ - compiler: ghc-8.8.3

48+ 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"]}}

4549 os: linux

4650 - compiler: ghc-8.6.5

47− 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"]}}

51+ 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"]}}

4852 os: linux

4953 - compiler: ghc-8.4.4

50− 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"]}}

54+ 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"]}}

5155 os: linux

5256 - compiler: ghc-8.2.2

53− 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"]}}

57+ 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"]}}

5458 os: linux

5559 - compiler: ghc-8.0.2

56− 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"]}}

60+ 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"]}}

5761 os: linux

5862before_install:

5963 - |

@@ -110,9 +114,9 @@ install:

110114 - cat $CABALHOME/config

111115 - rm -fv cabal.project cabal.project.local cabal.project.freeze

112116 - travis_retry ${CABAL} v2-update -v

113− - if ! $GHCJS ; then (cd /tmp && ${CABAL} v2-install $WITHCOMPILER -j2 doctest --constraint='doctest ==0.16.3.*') ; fi

114− - 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

115− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover) ; fi

117+ - if ! $GHCJS ; then ${CABAL} v2-install $WITHCOMPILER --ignore-project -j2 doctest --constraint='doctest ^>=0.16.3' ; fi

118+ - 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

119+ - if $GHCJS ; then ${CABAL} v2-install -w ghc-8.4.4 --ignore-project hspec-discover ; fi

116120 # Generate cabal.project

117121 - rm -rf cabal.project cabal.project.local cabal.project.freeze

118122 - touch cabal.project

@@ -130,15 +134,59 @@ install:

130134 if ! $GHCJS ; then echo "packages: servant-pipes" >> cabal.project ; fi

131135 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi

132136 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi

137+ if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/custom-errors" >> cabal.project ; fi

133138 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi

134139 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/db-postgres-pool" >> cabal.project ; fi

135140 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/file-upload" >> cabal.project ; fi

136141 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/generic" >> cabal.project ; fi

137142 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/pagination" >> cabal.project ; fi

138− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/testing" >> cabal.project ; fi

139143 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/structuring-apis" >> cabal.project ; fi

140144 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-custom-monad" >> cabal.project ; fi

141145 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-free-client" >> cabal.project ; fi

146+ - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant' >> cabal.project ; fi

147+ - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

148+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client' >> cabal.project ; fi

149+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

150+ - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client-core' >> cabal.project ; fi

151+ - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

152+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-http-streams' >> cabal.project ; fi

153+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

154+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-docs' >> cabal.project ; fi

155+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

156+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-foreign' >> cabal.project ; fi

157+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

158+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-server' >> cabal.project ; fi

159+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

160+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package tutorial' >> cabal.project ; fi

161+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

162+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-machines' >> cabal.project ; fi

163+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

164+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-conduit' >> cabal.project ; fi

165+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

166+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-pipes' >> cabal.project ; fi

167+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

168+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-auth' >> cabal.project ; fi

169+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

170+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-curl-mock' >> cabal.project ; fi

171+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

172+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-custom-errors' >> cabal.project ; fi

173+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

174+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-streaming' >> cabal.project ; fi

175+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

176+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-db-postgres-pool' >> cabal.project ; fi

177+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

178+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-file-upload' >> cabal.project ; fi

179+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

180+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-generic' >> cabal.project ; fi

181+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

182+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-pagination' >> cabal.project ; fi

183+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

184+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-structuring-apis' >> cabal.project ; fi

185+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

186+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-using-custom-monad' >> cabal.project ; fi

187+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

188+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-using-free-client' >> cabal.project ; fi

189+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

142190 - |

143191 echo "constraints: foundation >=0.0.14" >> cabal.project

144192 echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project

@@ -148,7 +196,7 @@ install:

148196 echo "allow-newer: servant-pagination-2.2.2:servant" >> cabal.project

149197 echo "allow-newer: servant-pagination-2.2.2:servant-server" >> cabal.project

150198 echo "optimization: False" >> cabal.project

151− - "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"

199+ - "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"

152200 - cat cabal.project || true

153201 - cat cabal.project.local || true

154202 - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi

@@ -164,12 +212,12 @@ install:

164212 - if [ -f "servant-pipes/configure.ac" ]; then (cd "servant-pipes" && autoreconf -i); fi

165213 - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then (cd "doc/cookbook/basic-auth" && autoreconf -i); fi

166214 - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then (cd "doc/cookbook/curl-mock" && autoreconf -i); fi

215+ - if [ -f "doc/cookbook/custom-errors/configure.ac" ]; then (cd "doc/cookbook/custom-errors" && autoreconf -i); fi

167216 - if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then (cd "doc/cookbook/basic-streaming" && autoreconf -i); fi

168217 - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then (cd "doc/cookbook/db-postgres-pool" && autoreconf -i); fi

169218 - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then (cd "doc/cookbook/file-upload" && autoreconf -i); fi

170219 - if [ -f "doc/cookbook/generic/configure.ac" ]; then (cd "doc/cookbook/generic" && autoreconf -i); fi

171220 - if [ -f "doc/cookbook/pagination/configure.ac" ]; then (cd "doc/cookbook/pagination" && autoreconf -i); fi

172− - if [ -f "doc/cookbook/testing/configure.ac" ]; then (cd "doc/cookbook/testing" && autoreconf -i); fi

173221 - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi

174222 - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi

175223 - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi

@@ -201,12 +249,12 @@ script:

201249 - PKGDIR_servant_pipes="$(find . -maxdepth 1 -type d -regex '.*/servant-pipes-[0-9.]*')"

202250 - PKGDIR_cookbook_basic_auth="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-auth-[0-9.]*')"

203251 - PKGDIR_cookbook_curl_mock="$(find . -maxdepth 1 -type d -regex '.*/cookbook-curl-mock-[0-9.]*')"

252+ - PKGDIR_cookbook_custom_errors="$(find . -maxdepth 1 -type d -regex '.*/cookbook-custom-errors-[0-9.]*')"

204253 - PKGDIR_cookbook_basic_streaming="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-streaming-[0-9.]*')"

205254 - PKGDIR_cookbook_db_postgres_pool="$(find . -maxdepth 1 -type d -regex '.*/cookbook-db-postgres-pool-[0-9.]*')"

206255 - PKGDIR_cookbook_file_upload="$(find . -maxdepth 1 -type d -regex '.*/cookbook-file-upload-[0-9.]*')"

207256 - PKGDIR_cookbook_generic="$(find . -maxdepth 1 -type d -regex '.*/cookbook-generic-[0-9.]*')"

208257 - PKGDIR_cookbook_pagination="$(find . -maxdepth 1 -type d -regex '.*/cookbook-pagination-[0-9.]*')"

209− - PKGDIR_cookbook_testing="$(find . -maxdepth 1 -type d -regex '.*/cookbook-testing-[0-9.]*')"

210258 - PKGDIR_cookbook_structuring_apis="$(find . -maxdepth 1 -type d -regex '.*/cookbook-structuring-apis-[0-9.]*')"

211259 - PKGDIR_cookbook_using_custom_monad="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-custom-monad-[0-9.]*')"

212260 - PKGDIR_cookbook_using_free_client="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-free-client-[0-9.]*')"

@@ -227,15 +275,59 @@ script:

227275 if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi

228276 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi

229277 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi

278+ if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_custom_errors}" >> cabal.project ; fi

230279 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi

231280 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_db_postgres_pool}" >> cabal.project ; fi

232281 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_file_upload}" >> cabal.project ; fi

233282 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_generic}" >> cabal.project ; fi

234283 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_pagination}" >> cabal.project ; fi

235− if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_testing}" >> cabal.project ; fi

236284 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_structuring_apis}" >> cabal.project ; fi

237285 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_custom_monad}" >> cabal.project ; fi

238286 if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_free_client}" >> cabal.project ; fi

287+ - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant' >> cabal.project ; fi

288+ - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

289+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client' >> cabal.project ; fi

290+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

291+ - if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-client-core' >> cabal.project ; fi

292+ - "if $GHCJS || ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

293+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-http-streams' >> cabal.project ; fi

294+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

295+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-docs' >> cabal.project ; fi

296+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

297+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-foreign' >> cabal.project ; fi

298+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

299+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-server' >> cabal.project ; fi

300+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

301+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package tutorial' >> cabal.project ; fi

302+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

303+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-machines' >> cabal.project ; fi

304+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

305+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-conduit' >> cabal.project ; fi

306+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

307+ - if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-pipes' >> cabal.project ; fi

308+ - "if ! $GHCJS && [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

309+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-auth' >> cabal.project ; fi

310+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

311+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-curl-mock' >> cabal.project ; fi

312+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

313+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-custom-errors' >> cabal.project ; fi

314+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

315+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-basic-streaming' >> cabal.project ; fi

316+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

317+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-db-postgres-pool' >> cabal.project ; fi

318+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

319+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-file-upload' >> cabal.project ; fi

320+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

321+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-generic' >> cabal.project ; fi

322+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

323+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-pagination' >> cabal.project ; fi

324+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

325+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-structuring-apis' >> cabal.project ; fi

326+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

327+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-using-custom-monad' >> cabal.project ; fi

328+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

329+ - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo 'package cookbook-using-free-client' >> cabal.project ; fi

330+ - "if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

239331 - |

240332 echo "constraints: foundation >=0.0.14" >> cabal.project

241333 echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project

@@ -245,7 +337,7 @@ script:

245337 echo "allow-newer: servant-pagination-2.2.2:servant" >> cabal.project

246338 echo "allow-newer: servant-pagination-2.2.2:servant-server" >> cabal.project

247339 echo "optimization: False" >> cabal.project

248− - "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"

340+ - "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"

249341 - cat cabal.project || true

250342 - cat cabal.project.local || true

251343 - |

@@ -264,12 +356,12 @@ script:

264356 servant-pipes) echo ${PKGDIR_servant_pipes} ;;

265357 cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;;

266358 cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;;

359+ cookbook-custom-errors) echo ${PKGDIR_cookbook_custom_errors} ;;

267360 cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;;

268361 cookbook-db-postgres-pool) echo ${PKGDIR_cookbook_db_postgres_pool} ;;

269362 cookbook-file-upload) echo ${PKGDIR_cookbook_file_upload} ;;

270363 cookbook-generic) echo ${PKGDIR_cookbook_generic} ;;

271364 cookbook-pagination) echo ${PKGDIR_cookbook_pagination} ;;

272− cookbook-testing) echo ${PKGDIR_cookbook_testing} ;;

273365 cookbook-structuring-apis) echo ${PKGDIR_cookbook_structuring_apis} ;;

274366 cookbook-using-custom-monad) echo ${PKGDIR_cookbook_using_custom_monad} ;;

275367 cookbook-using-free-client) echo ${PKGDIR_cookbook_using_free_client} ;;

@@ -303,5 +395,5 @@ script:

303395 - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi

304396 - echo -en 'travis_fold:end:haddock\\r'

305397

306−# REGENDATA ("0.9.20200121",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"])

398+# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"])

307399# EOF

cabal.project+2−1

@@ -22,6 +22,7 @@ packages:

2222packages:

2323 doc/cookbook/basic-auth

2424 doc/cookbook/curl-mock

25+ doc/cookbook/custom-errors

2526 doc/cookbook/basic-streaming

2627 doc/cookbook/db-postgres-pool

2728-- doc/cookbook/db-sqlite-simple

@@ -32,7 +33,7 @@ packages:

3233 -- doc/cookbook/jwt-and-basic-auth/

3334 doc/cookbook/pagination

3435 -- doc/cookbook/sentry

35− doc/cookbook/testing

36+-- doc/cookbook/testing

3637 doc/cookbook/structuring-apis

3738 doc/cookbook/using-custom-monad

3839 doc/cookbook/using-free-client

doc/cookbook/basic-auth/basic-auth.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-basic-auth

1414 main-is: BasicAuth.lhs

doc/cookbook/basic-streaming/basic-streaming.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-basic-streaming

1414 main-is: Streaming.lhs

doc/cookbook/curl-mock/curl-mock.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbock-curl-mock

1414 main-is: CurlMock.lhs

doc/cookbook/custom-errors/CustomErrors.lhsnew file+189

@@ -0,0 +1,189 @@

1+# Customizing errors from Servant

3+Servant handles a lot of parsing and validation of the input request. When it can't parse something: query

4+parameters, URL parts or request body, it will return appropriate HTTP codes like 400 Bad Request.

6+These responses will contain the error message in their body without any formatting. However, it is often

7+desirable to be able to provide custom formatting for these error messages, for example, to wrap them in JSON.

9+Recently Servant got a way to add such formatting. This Cookbook chapter demonstrates how to use it.

10+

11+Extensions and imports:

12+```haskell

13+{-# LANGUAGE DataKinds #-}

14+{-# LANGUAGE DeriveGeneric #-}

15+{-# LANGUAGE OverloadedStrings #-}

16+{-# LANGUAGE PolyKinds #-}

17+{-# LANGUAGE TypeFamilies #-}

18+{-# LANGUAGE TypeOperators #-}

19+

20+import Data.Aeson

21+import Data.Proxy

22+import Data.Text

23+import GHC.Generics

24+import Network.Wai

25+import Network.Wai.Handler.Warp

26+

27+import Servant

28+

29+import Data.String.Conversions

30+ (cs)

31+import Servant.API.ContentTypes

32+```

33+

34+The API (from `greet.hs` example in Servant sources):

35+

36+```haskell

37+-- | A greet message data type

38+newtype Greet = Greet { _msg :: Text }

39+ deriving (Generic, Show)

40+

41+instance FromJSON Greet

42+instance ToJSON Greet

43+

44+-- API specification

45+type TestApi =

46+ -- GET /hello/:name?capital={true, false} returns a Greet as JSON

47+ "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet

48+

49+ -- POST /greet with a Greet as JSON in the request body,

50+ -- returns a Greet as JSON

51+ :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet

52+

53+ -- DELETE /greet/:greetid

54+ :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent

55+

56+testApi :: Proxy TestApi

57+testApi = Proxy

58+

59+-- Server-side handlers.

60+--

61+-- There's one handler per endpoint, which, just like in the type

62+-- that represents the API, are glued together using :<|>.

63+--

64+-- Each handler runs in the 'Handler' monad.

65+server :: Server TestApi

66+server = helloH :<|> postGreetH :<|> deleteGreetH

67+

68+ where helloH name Nothing = helloH name (Just False)

69+ helloH name (Just False) = return . Greet $ "Hello, " <> name

70+ helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name

71+

72+ postGreetH greet = return greet

73+

74+ deleteGreetH _ = return NoContent

75+```

76+

77+## Error formatters

78+

79+`servant-server` provides an `ErrorFormatter` type to specify how the error message will be

80+formatted. A formatter is just a function accepting three parameters:

81+

82+- `TypeRep` from `Data.Typeable`: this is a runtime representation of the type of the combinator

83+ (like `Capture` or `ReqBody`) that generated the error. It can be used to display its name (with

84+ `show`) or even dynamically dispatch on the combinator type. See the docs for `Data.Typeable` and

85+ `Type.Reflection` modules.

86+- `Request`: full information for the request that led to the error.

87+- `String`: specific error message from the combinator.

88+

89+The formatter is expected to produce a `ServerError` which will be returned from the handler.

90+

91+Additionally, there is `NotFoundErrorFormatter`, which accepts only `Request` and can customize the

92+error in case when no route can be matched (HTTP 404).

93+

94+Let's make two formatters. First one will wrap our error in a JSON:

95+

96+```json

97+{

98+ "error": "ERROR MESSAGE",

99+ "combinator": "NAME OF THE COMBINATOR"

100+}

101+```

102+

103+Additionally, this formatter will examine the `Accept` header of the request and generate JSON

104+message only if client can accept it.

105+

106+```haskell

107+customFormatter :: ErrorFormatter

108+customFormatter tr req err =

109+ let

110+ -- aeson Value which will be sent to the client

111+ value = object ["combinator" .= show tr, "error" .= err]

112+ -- Accept header of the request

113+ accH = getAcceptHeader req

114+ in

115+ -- handleAcceptH is Servant's function that checks whether the client can accept a

116+ -- certain message type.

117+ -- In this case we call it with "Proxy '[JSON]" argument, meaning that we want to return a JSON.

118+ case handleAcceptH (Proxy :: Proxy '[JSON]) accH value of

119+ -- If client can't handle JSON, we just return the body the old way

120+ Nothing -> err400 { errBody = cs err }

121+ -- Otherwise, we return the JSON formatted body and set the "Content-Type" header.

122+ Just (ctypeH, body) -> err400

123+ { errBody = body

124+ , errHeaders = [("Content-Type", cs ctypeH)]

125+ }

126+

127+notFoundFormatter :: NotFoundErrorFormatter

128+notFoundFormatter req =

129+ err404 { errBody = cs $ "Not found path: " <> rawPathInfo req }

130+```

131+

132+If you don't need to react to the `Accept` header, you can just unconditionally return the JSON like

133+this (with `encode` from `Data.Aeson`):

134+

135+```

136+err400

137+ { errBody = encode body

138+ , errHeaders = [("Content-Type", "application/json")]

139+ }

140+```

141+

142+## Passing formatters to Servant

143+

144+Servant uses the Context to configure formatters. You only need to add a value of type

145+`ErrorFormatters` to your context. This is a record with the following fields:

146+

147+- `bodyParserErrorFormatter :: ErrorFormatter`

148+- `urlParseErrorFormatter :: ErrorFormatter`

149+- `headerParseErrorFormatter :: ErrorFormatter`

150+- `notFoundErrorFormatter :: NotFoundErrorFormatter`

151+

152+Default formatters are exported as `defaultErrorFormatters`, so you can use record update syntax to

153+set the only ones you need:

154+

155+```haskell

156+customFormatters :: ErrorFormatters

157+customFormatters = defaultErrorFormatters

158+ { bodyParserErrorFormatter = customFormatter

159+ , notFoundErrorFormatter = notFoundFormatter

160+ }

161+```

162+

163+And at last, use `serveWithContext` to run your server as usual:

164+

165+```haskell

166+app :: Application

167+app = serveWithContext testApi (customFormatters :. EmptyContext) server

168+

169+main :: IO ()

170+main = run 8000 app

171+```

172+

173+Now if we try to request something with a wrong body, we will get a nice error:

174+

175+```

176+$ http -j POST localhost:8000/greet 'foo=bar'

177+HTTP/1.1 400 Bad Request

178+Content-Type: application/json;charset=utf-8

179+Date: Fri, 17 Jul 2020 13:34:18 GMT

180+Server: Warp/3.3.12

181+Transfer-Encoding: chunked

182+

183+{

184+ "combinator": "ReqBody'",

185+ "error": "Error in $: parsing Main.Greet(Greet) failed, key \"_msg\" not found"

186+}

187+```

188+

189+Notice the `Content-Type` header set by our combinator.

doc/cookbook/custom-errors/custom-errors.cabalnew file+25

@@ -0,0 +1,25 @@

1+name: cookbook-custom-errors

2+version: 0.1

3+synopsis: Return custom error messages from combinators

4+homepage: http://docs.servant.dev

5+license: BSD3

6+license-file: ../../../servant/LICENSE

7+author: Servant Contributors

8+maintainer: haskell-servant-maintainers@googlegroups.com

9+build-type: Simple

10+cabal-version: >=1.10

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

12+

13+executable cookbook-custom-errors

14+ main-is: CustomErrors.lhs

15+ build-depends: base == 4.*

16+ , aeson

17+ , servant

18+ , servant-server

19+ , string-conversions

20+ , text

21+ , wai

22+ , warp

23+ default-language: Haskell2010

24+ ghc-options: -Wall -pgmL markdown-unlit

25+ build-tool-depends: markdown-unlit:markdown-unlit

doc/cookbook/db-postgres-pool/db-postgres-pool.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-db-postgres-pool

1414 main-is: PostgresPool.lhs

doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-db-sqlite-simple

1414 main-is: DBConnection.lhs

doc/cookbook/file-upload/file-upload.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-file-upload

1414 main-is: FileUpload.lhs

doc/cookbook/generic/generic.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-using-custom-monad

1414 main-is: Generic.lhs

doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal+1−1

@@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com

1111category: Servant

1212build-type: Simple

1313cabal-version: >=1.10

14−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

14+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1515

1616executable cookbook-hoist-server-with-context

1717 main-is: HoistServerWithContext.lhs

doc/cookbook/https/https.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-https

1414 main-is: Https.lhs

doc/cookbook/index.rst+1

@@ -25,6 +25,7 @@ you name it!

2525 db-postgres-pool/PostgresPool.lhs

2626 using-custom-monad/UsingCustomMonad.lhs

2727 using-free-client/UsingFreeClient.lhs

28+ custom-errors/CustomErrors.lhs

2829 basic-auth/BasicAuth.lhs

2930 basic-streaming/Streaming.lhs

3031 jwt-and-basic-auth/JWTAndBasicAuth.lhs

doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal+1−1

@@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com

1111category: Servant

1212build-type: Simple

1313cabal-version: >=1.10

14−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

14+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1515

1616executable cookbook-jwt-and-basic-auth

1717 main-is: JWTAndBasicAuth.lhs

doc/cookbook/pagination/pagination.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-pagination

1414 main-is: Pagination.lhs

doc/cookbook/sentry/sentry.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-sentry

1414 main-is: Sentry.lhs

doc/cookbook/structuring-apis/structuring-apis.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-structuring-apis

1414 main-is: StructuringApis.lhs

doc/cookbook/testing/testing.cabal+1−1

@@ -10,7 +10,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com

1010category: Servant

1111build-type: Simple

1212cabal-version: >=1.10

13−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

13+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1414

1515executable cookbook-testing

1616 main-is: Testing.lhs

doc/cookbook/using-custom-monad/using-custom-monad.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-using-custom-monad

1414 main-is: UsingCustomMonad.lhs

doc/cookbook/using-free-client/using-free-client.cabal+1−1

@@ -8,7 +8,7 @@ author: Servant Contributors

88maintainer: haskell-servant-maintainers@googlegroups.com

99build-type: Simple

1010cabal-version: >=1.10

11−tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.2

11+tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC ==8.10.1

1212

1313executable cookbook-using-free-client

1414 main-is: UsingFreeClient.lhs

doc/tutorial/tutorial.cabal+1−1

@@ -17,7 +17,7 @@ tested-with:

1717 GHC==8.2.2

1818 GHC==8.4.4

1919 GHC==8.6.5

20− GHC==8.8.2

20+ GHC==8.8.3, GHC ==8.10.1

2121extra-source-files:

2222 static/index.html

2323 static/ui.js

servant-client-core/servant-client-core.cabal+2−1

@@ -21,7 +21,8 @@ tested-with:

2121 || ==8.2.2

2222 || ==8.4.4

2323 || ==8.6.5

24− || ==8.8.2

24+ || ==8.8.3

25+ || ==8.10.1

2526 , GHCJS == 8.4

2627

2728extra-source-files:

servant-client/servant-client.cabal+2−1

@@ -25,7 +25,8 @@ tested-with:

2525 || ==8.2.2

2626 || ==8.4.4

2727 || ==8.6.5

28− || ==8.8.2

28+ || ==8.8.3

29+ || ==8.10.1

2930

3031extra-source-files:

3132 CHANGELOG.md

servant-conduit/servant-conduit.cabal+2−1

@@ -22,7 +22,8 @@ tested-with:

2222 || ==8.2.2

2323 || ==8.4.4

2424 || ==8.6.5

25− || ==8.8.2

25+ || ==8.8.3

26+ || ==8.10.1

2627

2728extra-source-files:

2829 CHANGELOG.md

servant-docs/servant-docs.cabal+2−1

@@ -24,7 +24,8 @@ tested-with:

2424 || ==8.2.2

2525 || ==8.4.4

2626 || ==8.6.5

27− || ==8.8.2

27+ || ==8.8.3

28+ || ==8.10.1

2829

2930extra-source-files:

3031 CHANGELOG.md

servant-foreign/servant-foreign.cabal+2−1

@@ -26,7 +26,8 @@ tested-with:

2626 || ==8.2.2

2727 || ==8.4.4

2828 || ==8.6.5

29− || ==8.8.2

29+ || ==8.8.3

30+ || ==8.10.1

3031

3132extra-source-files:

3233 CHANGELOG.md

servant-http-streams/servant-http-streams.cabal+2−1

@@ -25,7 +25,8 @@ tested-with:

2525 || ==8.2.2

2626 || ==8.4.4

2727 || ==8.6.5

28− || ==8.8.2

28+ || ==8.8.3

29+ || ==8.10.1

2930

3031extra-source-files:

3132 CHANGELOG.md

servant-machines/servant-machines.cabal+2−1

@@ -22,7 +22,8 @@ tested-with:

2222 || ==8.2.2

2323 || ==8.4.4

2424 || ==8.6.5

25− || ==8.8.2

25+ || ==8.8.3

26+ || ==8.10.1

2627

2728extra-source-files:

2829 CHANGELOG.md

servant-pipes/servant-pipes.cabal+2−1

@@ -22,7 +22,8 @@ tested-with:

2222 || ==8.2.2

2323 || ==8.4.4

2424 || ==8.6.5

25− || ==8.8.2

25+ || ==8.8.3

26+ || ==8.10.1

2627

2728extra-source-files:

2829 CHANGELOG.md

servant-server/servant-server.cabal+4−2

@@ -29,7 +29,8 @@ tested-with:

2929 || ==8.2.2

3030 || ==8.4.4

3131 || ==8.6.5

32− || ==8.8.2

32+ || ==8.8.3

33+ || ==8.10.1

3334

3435extra-source-files:

3536 CHANGELOG.md

@@ -50,9 +51,10 @@ library

5051 Servant.Server.Internal.Context

5152 Servant.Server.Internal.Delayed

5253 Servant.Server.Internal.DelayedIO

54+ Servant.Server.Internal.ErrorFormatter

5355 Servant.Server.Internal.Handler

54− Servant.Server.Internal.Router

5556 Servant.Server.Internal.RouteResult

57+ Servant.Server.Internal.Router

5658 Servant.Server.Internal.RoutingApplication

5759 Servant.Server.Internal.ServerError

5860 Servant.Server.StaticFiles

servant-server/src/Servant/Server.hs+30−2

@@ -3,6 +3,7 @@

33{-# LANGUAGE FlexibleContexts #-}

44{-# LANGUAGE RankNTypes #-}

55{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE TypeOperators #-}

78-- | This module lets you implement 'Server's for defined APIs. You'll

89-- most likely just need 'serve'.

@@ -35,6 +36,8 @@ module Servant.Server

3536 -- * Context

3637 , Context(..)

3738 , HasContextEntry(getContextEntry)

39+ , type (.++)

40+ , (.++)

3841 -- ** NamedContext

3942 , NamedContext(..)

4043 , descendIntoNamedContext

@@ -86,6 +89,24 @@ module Servant.Server

8689 , err504

8790 , err505

8891

92+ -- * Formatting of errors from combinators

93+ --

94+ -- | You can configure how Servant will render errors that occur while parsing the request.

95+

96+ , ErrorFormatter

97+ , NotFoundErrorFormatter

98+ , ErrorFormatters

99+

100+ , bodyParserErrorFormatter

101+ , urlParseErrorFormatter

102+ , headerParseErrorFormatter

103+ , notFoundErrorFormatter

104+

105+ , DefaultErrorFormatters

106+ , defaultErrorFormatters

107+

108+ , getAcceptHeader

109+

89110 -- * Re-exports

90111 , Application

91112 , Tagged (..)

@@ -129,10 +150,17 @@ import Servant.Server.Internal

129150serve :: (HasServer api '[]) => Proxy api -> Server api -> Application

130151serve p = serveWithContext p EmptyContext

131152

132−serveWithContext :: (HasServer api context)

153+-- | Like 'serve', but allows you to pass custom context.

154+--

155+-- 'defaultErrorFormatters' will always be appended to the end of the passed context,

156+-- but if you pass your own formatter, it will override the default one.

157+serveWithContext :: ( HasServer api context

158+ , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters )

133159 => Proxy api -> Context context -> Server api -> Application

134160serveWithContext p context server =

135− toApplication (runRouter (route p context (emptyDelayed (Route server))))

161+ toApplication (runRouter format404 (route p context (emptyDelayed (Route server))))

162+ where

163+ format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context

136164

137165-- | Hoist server implementation.

138166--

servant-server/src/Servant/Server/Generic.hs+1

@@ -67,6 +67,7 @@ genericServeTWithContext

6767 ( GenericServant routes (AsServerT m)

6868 , GenericServant routes AsApi

6969 , HasServer (ToServantApi routes) ctx

70+ , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters

7071 , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m)

7172 )

7273 => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler'

servant-server/src/Servant/Server/Internal.hs+71−43

@@ -24,6 +24,7 @@ module Servant.Server.Internal

2424 , module Servant.Server.Internal.Context

2525 , module Servant.Server.Internal.Delayed

2626 , module Servant.Server.Internal.DelayedIO

27+ , module Servant.Server.Internal.ErrorFormatter

2728 , module Servant.Server.Internal.Handler

2829 , module Servant.Server.Internal.Router

2930 , module Servant.Server.Internal.RouteResult

@@ -95,6 +96,7 @@ import Servant.Server.Internal.BasicAuth

9596import Servant.Server.Internal.Context

9697import Servant.Server.Internal.Delayed

9798import Servant.Server.Internal.DelayedIO

99+import Servant.Server.Internal.ErrorFormatter

98100import Servant.Server.Internal.Handler

99101import Servant.Server.Internal.Router

100102import Servant.Server.Internal.RouteResult

@@ -168,7 +170,10 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont

168170-- > server = getBook

169171-- > where getBook :: Text -> Handler Book

170172-- > getBook isbn = ...

171−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods))

173+instance (KnownSymbol capture, FromHttpApiData a

174+ , HasServer api context, SBoolI (FoldLenient mods)

175+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

176+ )

172177 => HasServer (Capture' mods capture a :> api) context where

173178

174179 type ServerT (Capture' mods capture a :> api) m =

@@ -180,12 +185,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI

180185 CaptureRouter $

181186 route (Proxy :: Proxy api)

182187 context

183− (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods)

184− , parseUrlPiece txt :: Either T.Text a) of

185− (SFalse, Left e) -> delayedFail err400 { errBody = cs e }

186− (SFalse, Right v) -> return v

187− (STrue, piece) -> return $ (either (Left . cs) Right) piece

188− )

188+ (addCapture d $ \ txt -> withRequest $ \ request ->

189+ case ( sbool :: SBool (FoldLenient mods)

190+ , parseUrlPiece txt :: Either T.Text a) of

191+ (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e

192+ (SFalse, Right v) -> return v

193+ (STrue, piece) -> return $ (either (Left . cs) Right) piece)

194+ where

195+ rep = typeRep (Proxy :: Proxy Capture')

196+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

189197

190198-- | If you use 'CaptureAll' in one of the endpoints for your API,

191199-- this automatically requires your server-side handler to be a

@@ -204,7 +212,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI

204212-- > server = getSourceFile

205213-- > where getSourceFile :: [Text] -> Handler Book

206214-- > getSourceFile pathSegments = ...

207−instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

215+instance (KnownSymbol capture, FromHttpApiData a

216+ , HasServer api context

217+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

218+ )

208219 => HasServer (CaptureAll capture a :> api) context where

209220

210221 type ServerT (CaptureAll capture a :> api) m =

@@ -216,11 +227,14 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context)

216227 CaptureAllRouter $

217228 route (Proxy :: Proxy api)

218229 context

219− (addCapture d $ \ txts -> case parseUrlPieces txts of

220− Left _ -> delayedFail err400

221− Right v -> return v

230+ (addCapture d $ \ txts -> withRequest $ \ request ->

231+ case parseUrlPieces txts of

232+ Left e -> delayedFail $ formatError rep request $ cs e

233+ Right v -> return v

222234 )

223−

235+ where

236+ rep = typeRep (Proxy :: Proxy CaptureAll)

237+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

224238

225239allowedMethodHead :: Method -> Request -> Bool

226240allowedMethodHead method request = method == methodGet && requestMethod request == methodHead

@@ -240,10 +254,10 @@ methodCheck method request

240254-- body check is no longer an option. However, we now run the accept

241255-- check before the body check and can therefore afford to make it

242256-- recoverable.

243−acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO ()

257+acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO ()

244258acceptCheck proxy accH

245− | canHandleAcceptH proxy (AcceptHeader accH) = return ()

246− | otherwise = delayedFail err406

259+ | canHandleAcceptH proxy accH = return ()

260+ | otherwise = delayedFail err406

247261

248262methodRouter :: (AllCTRender ctypes a)

249263 => (b -> ([(HeaderName, B.ByteString)], a))

@@ -253,12 +267,12 @@ methodRouter :: (AllCTRender ctypes a)

253267methodRouter splitHeaders method proxy status action = leafRouter route'

254268 where

255269 route' env request respond =

256− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

270+ let accH = getAcceptHeader request

257271 in runAction (action `addMethodCheck` methodCheck method request

258272 `addAcceptCheck` acceptCheck proxy accH

259273 ) env request respond $ \ output -> do

260274 let (headers, b) = splitHeaders output

261− case handleAcceptH proxy (AcceptHeader accH) b of

275+ case handleAcceptH proxy accH b of

262276 Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does

263277 Just (contentT, body) ->

264278 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

343357 -> Delayed env (Handler c)

344358 -> Router env

345359streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->

346− let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request

360+ let AcceptHeader accH = getAcceptHeader request

347361 cmediatype = NHM.matchAccept [contentType ctypeproxy] accH

348362 accCheck = when (isNothing cmediatype) $ delayedFail err406

349363 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype)

@@ -388,6 +402,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou

388402instance

389403 (KnownSymbol sym, FromHttpApiData a, HasServer api context

390404 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

405+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

391406 )

392407 => HasServer (Header' mods sym a :> api) context where

393408------

@@ -399,6 +414,9 @@ instance

399414 route Proxy context subserver = route (Proxy :: Proxy api) context $

400415 subserver `addHeaderCheck` withRequest headerCheck

401416 where

417+ rep = typeRep (Proxy :: Proxy Header')

418+ formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

419+

402420 headerName :: IsString n => n

403421 headerName = fromString $ symbolVal (Proxy :: Proxy sym)

404422

@@ -409,15 +427,13 @@ instance

409427 mev :: Maybe (Either T.Text a)

410428 mev = fmap parseHeader $ lookup headerName (requestHeaders req)

411429

412− errReq = delayedFailFatal err400

413− { errBody = "Header " <> headerName <> " is required"

414− }

430+ errReq = delayedFailFatal $ formatError rep req

431+ $ "Header " <> headerName <> " is required"

415432

416− errSt e = delayedFailFatal err400

417− { errBody = cs $ "Error parsing header "

418− <> headerName

419− <> " failed: " <> e

420− }

433+ errSt e = delayedFailFatal $ formatError rep req

434+ $ cs $ "Error parsing header "

435+ <> headerName

436+ <> " failed: " <> e

421437

422438-- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API,

423439-- this automatically requires your server-side handler to be a function

@@ -443,6 +459,7 @@ instance

443459instance

444460 ( KnownSymbol sym, FromHttpApiData a, HasServer api context

445461 , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)

462+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

446463 )

447464 => HasServer (QueryParam' mods sym a :> api) context where

448465------

@@ -455,6 +472,9 @@ instance

455472 let querytext = queryToQueryText . queryString

456473 paramname = cs $ symbolVal (Proxy :: Proxy sym)

457474

475+ rep = typeRep (Proxy :: Proxy QueryParam')

476+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

477+

458478 parseParam :: Request -> DelayedIO (RequestArgument mods a)

459479 parseParam req =

460480 unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev

@@ -462,14 +482,12 @@ instance

462482 mev :: Maybe (Either T.Text a)

463483 mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req

464484

465− errReq = delayedFailFatal err400

466− { errBody = cs $ "Query parameter " <> paramname <> " is required"

467− }

485+ errReq = delayedFailFatal $ formatError rep req

486+ $ cs $ "Query parameter " <> paramname <> " is required"

468487

469− errSt e = delayedFailFatal err400

470− { errBody = cs $ "Error parsing query parameter "

471− <> paramname <> " failed: " <> e

472− }

488+ errSt e = delayedFailFatal $ formatError rep req

489+ $ cs $ "Error parsing query parameter "

490+ <> paramname <> " failed: " <> e

473491

474492 delayed = addParameterCheck subserver . withRequest $ \req ->

475493 parseParam req

@@ -495,7 +513,8 @@ instance

495513-- > server = getBooksBy

496514-- > where getBooksBy :: [Text] -> Handler [Book]

497515-- > getBooksBy authors = ...return all books by these authors...

498−instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

516+instance (KnownSymbol sym, FromHttpApiData a, HasServer api context

517+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters)

499518 => HasServer (QueryParams sym a :> api) context where

500519

501520 type ServerT (QueryParams sym a :> api) m =

@@ -506,21 +525,23 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)

506525 route Proxy context subserver = route (Proxy :: Proxy api) context $

507526 subserver `addParameterCheck` withRequest paramsCheck

508527 where

528+ rep = typeRep (Proxy :: Proxy QueryParams)

529+ formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

530+

509531 paramname = cs $ symbolVal (Proxy :: Proxy sym)

510532 paramsCheck req =

511533 case partitionEithers $ fmap parseQueryParam params of

512534 ([], parsed) -> return parsed

513− (errs, _) -> delayedFailFatal err400

514− { errBody = cs $ "Error parsing query parameter(s) "

515− <> paramname <> " failed: "

516− <> T.intercalate ", " errs

517− }

535+ (errs, _) -> delayedFailFatal $ formatError rep req

536+ $ cs $ "Error parsing query parameter(s) "

537+ <> paramname <> " failed: "

538+ <> T.intercalate ", " errs

518539 where

519540 params :: [T.Text]

520541 params = mapMaybe snd

521542 . filter (looksLikeParam . fst)

522− . queryToQueryText

523− . queryString

543+ . queryToQueryText

544+ . queryString

524545 $ req

525546

526547 looksLikeParam name = name == paramname || name == (paramname <> "[]")

@@ -588,7 +609,7 @@ instance HasServer Raw context where

588609-- The @Content-Type@ header is inspected, and the list provided is used to

589610-- attempt deserialization. If the request does not have a @Content-Type@

590611-- header, it is treated as @application/octet-stream@ (as specified in

591−-- <http://tools.ietf.org/html/rfc7231#section-3.1.1.5 RFC7231>.

612+-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)).

592613-- This lets servant worry about extracting it from the request and turning

593614-- it into a value of the type you specify.

594615--

@@ -604,6 +625,7 @@ instance HasServer Raw context where

604625-- > where postBook :: Book -> Handler Book

605626-- > postBook book = ...insert into your db...

606627instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods)

628+ , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters

607629 ) => HasServer (ReqBody' mods list a :> api) context where

608630

609631 type ServerT (ReqBody' mods list a :> api) m =

@@ -615,6 +637,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods

615637 = route (Proxy :: Proxy api) context $

616638 addBodyCheck subserver ctCheck bodyCheck

617639 where

640+ rep = typeRep (Proxy :: Proxy ReqBody')

641+ formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context)

642+

618643 -- Content-Type check, we only lookup we can try to parse the request body

619644 ctCheck = withRequest $ \ request -> do

620645 -- See HTTP RFC 2616, section 7.2.1

@@ -633,7 +658,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods

633658 case sbool :: SBool (FoldLenient mods) of

634659 STrue -> return mrqbody

635660 SFalse -> case mrqbody of

636− Left e -> delayedFailFatal err400 { errBody = cs e }

661+ Left e -> delayedFailFatal $ formatError rep request e

637662 Right v -> return v

638663

639664instance

@@ -761,6 +786,9 @@ instance ( KnownSymbol realm

761786ct_wildcard :: B.ByteString

762787ct_wildcard = "*" <> "/" <> "*" -- Because CPP

763788

789+getAcceptHeader :: Request -> AcceptHeader

790+getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders

791+

764792-- * General Authentication

765793

766794

servant-server/src/Servant/Server/Internal/Context.hs+23−8

@@ -1,11 +1,12 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE KindSignatures #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeOperators #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE TypeOperators #-}

910

1011module Servant.Server.Internal.Context where

1112

@@ -45,6 +46,20 @@ instance Eq (Context '[]) where

4546instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where

4647 x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2

4748

49+-- | Append two type-level lists.

50+--

51+-- Hint: import it as

52+--

53+-- > import Servant.Server (type (.++))

54+type family (.++) (l1 :: [*]) (l2 :: [*]) where

55+ '[] .++ a = a

56+ (a ': as) .++ b = a ': (as .++ b)

57+

58+-- | Append two contexts.

59+(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2)

60+EmptyContext .++ a = a

61+(a :. as) .++ b = a :. (as .++ b)

62+

4863-- | This class is used to access context entries in 'Context's. 'getContextEntry'

4964-- returns the first value where the type matches:

5065--

servant-server/src/Servant/Server/Internal/ErrorFormatter.hsnew file+79

@@ -0,0 +1,79 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE KindSignatures #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE TypeOperators #-}

7+module Servant.Server.Internal.ErrorFormatter

8+ where

10+import Data.String.Conversions

11+ (cs)

12+import Data.Typeable

13+import Network.Wai.Internal

14+ (Request)

15+

16+import Servant.API

17+ (Capture, ReqBody)

18+import Servant.Server.Internal.Context

19+import Servant.Server.Internal.ServerError

20+

21+-- | 'Context' that contains default error formatters.

22+type DefaultErrorFormatters = '[ErrorFormatters]

23+

24+-- | A collection of error formatters for different situations.

25+--

26+-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax.

27+data ErrorFormatters = ErrorFormatters

28+ { -- | Format error from parsing the request body.

29+ bodyParserErrorFormatter :: ErrorFormatter

30+ -- | Format error from parsing url parts or query parameters.

31+ , urlParseErrorFormatter :: ErrorFormatter

32+ -- | Format error from parsing request headers.

33+ , headerParseErrorFormatter :: ErrorFormatter

34+ -- | Format error for not found URLs.

35+ , notFoundErrorFormatter :: NotFoundErrorFormatter

36+ }

37+

38+-- | Default formatters will just return HTTP 400 status code with error

39+-- message as response body.

40+defaultErrorFormatters :: ErrorFormatters

41+defaultErrorFormatters = ErrorFormatters

42+ { bodyParserErrorFormatter = err400Formatter

43+ , urlParseErrorFormatter = err400Formatter

44+ , headerParseErrorFormatter = err400Formatter

45+ , notFoundErrorFormatter = const err404

46+ }

47+

48+-- | A custom formatter for errors produced by parsing combinators like

49+-- 'ReqBody' or 'Capture'.

50+--

51+-- A 'TypeRep' argument described the concrete combinator that raised

52+-- the error, allowing formatter to customize the message for different

53+-- combinators.

54+--

55+-- A full 'Request' is also passed so that the formatter can react to @Accept@ header,

56+-- for example.

57+type ErrorFormatter = TypeRep -> Request -> String -> ServerError

58+

59+-- | This formatter does not get neither 'TypeRep' nor error message.

60+type NotFoundErrorFormatter = Request -> ServerError

61+

62+type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters

63+

64+mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx)

65+mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext)

66+

67+-- Internal

68+

69+err400Formatter :: ErrorFormatter

70+err400Formatter _ _ e = err400 { errBody = cs e }

71+

72+-- These definitions suppress "unused import" warning.

73+-- The imorts are needed for Haddock to correctly link to them.

74+_RB :: Proxy ReqBody

75+_RB = undefined

76+_C :: Proxy Capture

77+_C = undefined

78+_CT :: Proxy Context

79+_CT = undefined

servant-server/src/Servant/Server/Internal/Router.hs+19−18

@@ -17,8 +17,9 @@ import Data.Text

1717import qualified Data.Text as T

1818import Network.Wai

1919 (Response, pathInfo)

20−import Servant.Server.Internal.RoutingApplication

20+import Servant.Server.Internal.ErrorFormatter

2121import Servant.Server.Internal.RouteResult

22+import Servant.Server.Internal.RoutingApplication

2223import Servant.Server.Internal.ServerError

2324

2425type Router env = Router' env RoutingApplication

@@ -153,52 +154,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env ->

153154tweakResponse f = fmap (\a -> \req cont -> a req (cont . f))

154155

155156-- | Interpret a router as an application.

156−runRouter :: Router () -> RoutingApplication

157−runRouter r = runRouterEnv r ()

157+runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication

158+runRouter fmt r = runRouterEnv fmt r ()

158159

159−runRouterEnv :: Router env -> env -> RoutingApplication

160−runRouterEnv router env request respond =

160+runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication

161+runRouterEnv fmt router env request respond =

161162 case router of

162163 StaticRouter table ls ->

163164 case pathInfo request of

164− [] -> runChoice ls env request respond

165+ [] -> runChoice fmt ls env request respond

165166 -- This case is to handle trailing slashes.

166− [""] -> runChoice ls env request respond

167+ [""] -> runChoice fmt ls env request respond

167168 first : rest | Just router' <- M.lookup first table

168169 -> let request' = request { pathInfo = rest }

169− in runRouterEnv router' env request' respond

170− _ -> respond $ Fail err404

170+ in runRouterEnv fmt router' env request' respond

171+ _ -> respond $ Fail $ fmt request

171172 CaptureRouter router' ->

172173 case pathInfo request of

173− [] -> respond $ Fail err404

174+ [] -> respond $ Fail $ fmt request

174175 -- This case is to handle trailing slashes.

175− [""] -> respond $ Fail err404

176+ [""] -> respond $ Fail $ fmt request

176177 first : rest

177178 -> let request' = request { pathInfo = rest }

178− in runRouterEnv router' (first, env) request' respond

179+ in runRouterEnv fmt router' (first, env) request' respond

179180 CaptureAllRouter router' ->

180181 let segments = pathInfo request

181182 request' = request { pathInfo = [] }

182− in runRouterEnv router' (segments, env) request' respond

183+ in runRouterEnv fmt router' (segments, env) request' respond

183184 RawRouter app ->

184185 app env request respond

185186 Choice r1 r2 ->

186− runChoice [runRouterEnv r1, runRouterEnv r2] env request respond

187+ runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond

187188

188189-- | Try a list of routing applications in order.

189190-- We stop as soon as one fails fatally or succeeds.

190191-- If all fail normally, we pick the "best" error.

191192--

192−runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication

193−runChoice ls =

193+runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication

194+runChoice fmt ls =

194195 case ls of

195− [] -> \ _ _ respond -> respond (Fail err404)

196+ [] -> \ _ request respond -> respond (Fail $ fmt request)

196197 [r] -> r

197198 (r : rs) ->

198199 \ env request respond ->

199200 r env request $ \ response1 ->

200201 case response1 of

201− Fail _ -> runChoice rs env request $ \ response2 ->

202+ Fail _ -> runChoice fmt rs env request $ \ response2 ->

202203 respond $ highestPri response1 response2

203204 _ -> respond response1

204205 where

servant-server/test/Servant/Server/ErrorSpec.hs+58

@@ -15,6 +15,8 @@ import qualified Data.ByteString.Lazy.Char8 as BCL

1515import Data.Monoid

1616 ((<>))

1717import Data.Proxy

18+import Data.String.Conversions

19+ (cs)

1820import Network.HTTP.Types

1921 (hAccept, hAuthorization, hContentType, methodGet, methodPost,

2022 methodPut)

@@ -31,6 +33,7 @@ spec = describe "HTTP Errors" $ do

3133 prioErrorsSpec

3234 errorRetrySpec

3335 errorChoiceSpec

36+ customFormattersSpec

3437

3538-- * Auth machinery (reused throughout)

3639

@@ -293,6 +296,61 @@ errorChoiceSpec = describe "Multiple handlers return errors"

293296 `shouldRespondWith` 415

294297

295298

299+-- }}}

300+------------------------------------------------------------------------------

301+-- * Custom errors {{{

302+

303+customFormatter :: ErrorFormatter

304+customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs err }

305+

306+customFormatters :: ErrorFormatters

307+customFormatters = defaultErrorFormatters

308+ { bodyParserErrorFormatter = customFormatter

309+ , urlParseErrorFormatter = customFormatter

310+ , notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" }

311+ }

312+

313+type CustomFormatterAPI

314+ = "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String

315+ :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String

316+ :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String

317+

318+customFormatterAPI :: Proxy CustomFormatterAPI

319+customFormatterAPI = Proxy

320+

321+customFormatterServer :: Server CustomFormatterAPI

322+customFormatterServer = (\_ -> return "query")

323+ :<|> (\_ -> return "capture")

324+ :<|> (\_ -> return "body")

325+

326+customFormattersSpec :: Spec

327+customFormattersSpec = describe "Custom errors from combinators"

328+ $ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do

329+

330+ let startsWithCustom = ResponseMatcher

331+ { matchStatus = 400

332+ , matchHeaders = []

333+ , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BCL.isPrefixOf` body

334+ then Nothing

335+ else Just $ show body <> " does not start with \"CUSTOM!\""

336+ }

337+

338+ it "formats query parse error" $ do

339+ request methodGet "query?param=false" [] ""

340+ `shouldRespondWith` startsWithCustom

341+

342+ it "formats query parse error with missing param" $ do

343+ request methodGet "query" [] ""

344+ `shouldRespondWith` startsWithCustom

345+

346+ it "formats capture parse error" $ do

347+ request methodGet "capture/42" [] ""

348+ `shouldRespondWith` startsWithCustom

349+

350+ it "formats body parse error" $ do

351+ request methodPost "body" [(hContentType, "application/json")] "foo"

352+ `shouldRespondWith` startsWithCustom

353+

296354-- }}}

297355------------------------------------------------------------------------------

298356-- * Instances {{{

servant-server/test/Servant/Server/RouterSpec.hs+2−2

@@ -32,7 +32,7 @@ routerSpec :: Spec

3232routerSpec = do

3333 describe "tweakResponse" $ do

3434 let app' :: Application

35− app' = toApplication $ runRouter router'

35+ app' = toApplication $ runRouter (const err404) router'

3636

3737 router', router :: Router ()

3838 router' = tweakResponse (fmap twk) router

@@ -48,7 +48,7 @@ routerSpec = do

4848

4949 describe "runRouter" $ do

5050 let toApp :: Router () -> Application

51− toApp = toApplication . runRouter

51+ toApp = toApplication . runRouter (const err404)

5252

5353 cap :: Router ()

5454 cap = CaptureRouter $

servant/servant.cabal+2−1

@@ -25,7 +25,8 @@ tested-with:

2525 || ==8.2.2

2626 || ==8.4.4

2727 || ==8.6.5

28− || ==8.8.2

28+ || ==8.8.3

29+ || ==8.10.1

2930 , GHCJS == 8.4

3031

3132extra-source-files:

servant/src/Servant/API/Header.hs+1−1

@@ -23,7 +23,7 @@ import Servant.API.Modifiers

2323-- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer

2424type Header = Header' '[Optional, Strict]

2525

26−data Header' (mods :: [*]) (sym :: Symbol) a

26+data Header' (mods :: [*]) (sym :: Symbol) (a :: *)

2727 deriving Typeable

2828

2929-- $setup