eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge branch 'master' into 309-handle-application-exceptions-with-500-errors

Browse source
This commit is contained in:
Sasa Bogicevic 2018-06-10 18:35:52 +02:00
commit 64686f3ec9
No known key found for this signature in database
GPG key ID: CD9374C0A58CBA95
34 changed files with 404 additions and 248 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

77
.travis.yml
View file

@ -1,6 +1,6 @@
# This Travis job script has been generated by a script via # This Travis job script has been generated by a script via
# #
# runghc make_travis_yml_2.hs '--config=cabal.make-travis-yml' '--output=.travis.yml' '--max-backjumps=10000' 'cabal.project' # runghc make_travis_yml_2.hs '--config=cabal.make-travis-yml' '--output=.travis.yml' 'cabal.project'
# #
# For more information, see https://github.com/hvr/multi-ghc-travis # For more information, see https://github.com/hvr/multi-ghc-travis
# #
@ -33,18 +33,21 @@ before_cache:
matrix: matrix:
include: include:
- compiler: "ghc-7.8.4" - compiler: "ghc-8.4.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks # env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}} addons: {apt: {packages: [ghc-ppa-tools,ghc-8.4.3], sources: [hvr-ghc]}}
- compiler: "ghc-7.10.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}
- compiler: "ghc-8.0.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
- compiler: "ghc-8.2.2" - compiler: "ghc-8.2.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks # env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} addons: {apt: {packages: [ghc-ppa-tools,ghc-8.2.2], sources: [hvr-ghc]}}
- compiler: "ghc-8.0.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,ghc-8.0.2], sources: [hvr-ghc]}}
- compiler: "ghc-7.10.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,ghc-7.10.3], sources: [hvr-ghc]}}
- compiler: "ghc-7.8.4"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,ghc-7.8.4], sources: [hvr-ghc]}}
before_install: before_install:
- HC=${CC} - HC=${CC}
@ -56,6 +59,17 @@ before_install:
- HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
- echo $HCNUMVER - echo $HCNUMVER
# Let's download "better" cabal
- "curl -L http://oleg.fi/cabal-grayjay-buildable-fix.xz | xz -d > $HOME/.local/bin/cabal"
- |
if [ "$(cd $HOME/.local/bin && sha256sum cabal)" != "e281e9466b8eef30ac0d1371e8ea83c9d2e856bda4714a728ac474138b09b20f cabal" ]; then
rm -f $HOME/.local/bin/cabal;
sha256sum $HOME/.local/bin/cabal;
false;
else
chmod a+x $HOME/.local/bin/cabal;
fi
install: install:
- cabal --version - cabal --version
- echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
@ -64,15 +78,14 @@ install:
- HADDOCK=${HADDOCK-true} - HADDOCK=${HADDOCK-true}
- INSTALLED=${INSTALLED-true} - INSTALLED=${INSTALLED-true}
- GHCHEAD=${GHCHEAD-false} - GHCHEAD=${GHCHEAD-false}
- CABALNEWBUILDOPTS=--max-backjumps=10000
- travis_retry cabal update -v - travis_retry cabal update -v
- "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
- rm -fv cabal.project cabal.project.local - rm -fv cabal.project cabal.project.local
- "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi" - "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
- grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
- "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/basic-auth\" \"doc/cookbook/https\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/file-upload\"\\n' > cabal.project" - "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/basic-auth\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/https\" \"doc/cookbook/pagination\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\"\\n' > cabal.project"
- "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project" - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
- "echo 'allow-newer: servant-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server' >> cabal.project" - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project"
- cat cabal.project - cat cabal.project
- if [ -f "servant/configure.ac" ]; then - if [ -f "servant/configure.ac" ]; then
(cd "servant" && autoreconf -i); (cd "servant" && autoreconf -i);
@ -95,32 +108,29 @@ install:
- if [ -f "doc/tutorial/configure.ac" ]; then - if [ -f "doc/tutorial/configure.ac" ]; then
(cd "doc/tutorial" && autoreconf -i); (cd "doc/tutorial" && autoreconf -i);
fi fi
- if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then
(cd "doc/cookbook/basic-auth" && autoreconf -i);
fi
- if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then
(cd "doc/cookbook/db-postgres-pool" && autoreconf -i); (cd "doc/cookbook/db-postgres-pool" && autoreconf -i);
fi fi
- if [ -f "doc/cookbook/jwt-and-basic-auth/configure.ac" ]; then
(cd "doc/cookbook/jwt-and-basic-auth" && autoreconf -i);
fi
- if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then - if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then
(cd "doc/cookbook/db-sqlite-simple" && autoreconf -i); (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);
fi fi
- if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then
(cd "doc/cookbook/basic-auth" && autoreconf -i);
fi
- if [ -f "doc/cookbook/https/configure.ac" ]; then - if [ -f "doc/cookbook/https/configure.ac" ]; then
(cd "doc/cookbook/https" && autoreconf -i); (cd "doc/cookbook/https" && autoreconf -i);
fi fi
- if [ -f "doc/cookbook/pagination/configure.ac" ]; then
(cd "doc/cookbook/pagination" && autoreconf -i);
fi
- if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then
(cd "doc/cookbook/structuring-apis" && autoreconf -i); (cd "doc/cookbook/structuring-apis" && autoreconf -i);
fi fi
- if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then
(cd "doc/cookbook/using-custom-monad" && autoreconf -i); (cd "doc/cookbook/using-custom-monad" && autoreconf -i);
fi fi
- if [ -f "doc/cookbook/file-upload/configure.ac" ]; then
(cd "doc/cookbook/file-upload" && autoreconf -i);
fi
- rm -f cabal.project.freeze - rm -f cabal.project.freeze
- rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/https"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/file-upload"/dist - rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/https"/dist "doc/cookbook/pagination"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
# Here starts the actual work to be performed for the package under test; # Here starts the actual work to be performed for the package under test;
@ -135,37 +145,36 @@ script:
- (cd "servant-foreign" && cabal sdist) - (cd "servant-foreign" && cabal sdist)
- (cd "servant-server" && cabal sdist) - (cd "servant-server" && cabal sdist)
- (cd "doc/tutorial" && cabal sdist) - (cd "doc/tutorial" && cabal sdist)
- (cd "doc/cookbook/db-postgres-pool" && cabal sdist)
- (cd "doc/cookbook/jwt-and-basic-auth" && cabal sdist)
- (cd "doc/cookbook/db-sqlite-simple" && cabal sdist)
- (cd "doc/cookbook/basic-auth" && cabal sdist) - (cd "doc/cookbook/basic-auth" && cabal sdist)
- (cd "doc/cookbook/db-postgres-pool" && cabal sdist)
- (cd "doc/cookbook/db-sqlite-simple" && cabal sdist)
- (cd "doc/cookbook/https" && cabal sdist) - (cd "doc/cookbook/https" && cabal sdist)
- (cd "doc/cookbook/pagination" && cabal sdist)
- (cd "doc/cookbook/structuring-apis" && cabal sdist) - (cd "doc/cookbook/structuring-apis" && cabal sdist)
- (cd "doc/cookbook/using-custom-monad" && cabal sdist) - (cd "doc/cookbook/using-custom-monad" && cabal sdist)
- (cd "doc/cookbook/file-upload" && cabal sdist)
- echo -en 'travis_fold:end:sdist\\r' - echo -en 'travis_fold:end:sdist\\r'
- echo Unpacking... && echo -en 'travis_fold:start:unpack\\r' - echo Unpacking... && echo -en 'travis_fold:start:unpack\\r'
- mv "servant"/dist/servant-*.tar.gz "servant-client"/dist/servant-client-*.tar.gz "servant-client-core"/dist/servant-client-core-*.tar.gz "servant-docs"/dist/servant-docs-*.tar.gz "servant-foreign"/dist/servant-foreign-*.tar.gz "servant-server"/dist/servant-server-*.tar.gz "doc/tutorial"/dist/tutorial-*.tar.gz "doc/cookbook/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/jwt-and-basic-auth"/dist/cookbook-jwt-and-basic-auth-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz "doc/cookbook/file-upload"/dist/cookbook-file-upload-*.tar.gz ${DISTDIR}/ - mv "servant"/dist/servant-*.tar.gz "servant-client"/dist/servant-client-*.tar.gz "servant-client-core"/dist/servant-client-core-*.tar.gz "servant-docs"/dist/servant-docs-*.tar.gz "servant-foreign"/dist/servant-foreign-*.tar.gz "servant-server"/dist/servant-server-*.tar.gz "doc/tutorial"/dist/tutorial-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/pagination"/dist/cookbook-pagination-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz ${DISTDIR}/
- cd ${DISTDIR} || false - cd ${DISTDIR} || false
- find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
- "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-https-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-file-upload-*/*.cabal\\n' > cabal.project" - "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-https-*/*.cabal cookbook-pagination-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal\\n' > cabal.project"
- "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project" - "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
- "echo 'allow-newer: servant-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server' >> cabal.project" - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project"
- cat cabal.project - cat cabal.project
- echo -en 'travis_fold:end:unpack\\r' - echo -en 'travis_fold:end:unpack\\r'
- echo Building with tests and benchmarks... && echo -en 'travis_fold:start:build-everything\\r' - echo Building with tests and benchmarks... && echo -en 'travis_fold:start:build-everything\\r'
# build & run tests, build benchmarks # build & run tests, build benchmarks
- cabal new-build -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all - cabal new-build -w ${HC} ${TEST} ${BENCH} all
- echo -en 'travis_fold:end:build-everything\\r' - echo -en 'travis_fold:end:build-everything\\r'
- if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all; fi - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi
- echo Haddock... && echo -en 'travis_fold:start:haddock\\r' - echo Haddock... && echo -en 'travis_fold:start:haddock\\r'
# haddock # haddock
- rm -rf ./dist-newstyle - rm -rf ./dist-newstyle
- if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all; else echo "Skipping haddock generation";fi - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
- echo -en 'travis_fold:end:haddock\\r' - echo -en 'travis_fold:end:haddock\\r'
# REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","--max-backjumps=10000","cabal.project"] # REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","cabal.project"]
# EOF # EOF

24
cabal.project
View file

@ -5,19 +5,29 @@ packages: servant/
servant-foreign/ servant-foreign/
servant-server/ servant-server/
doc/tutorial/ doc/tutorial/
doc/cookbook/*/*.cabal
-- doc/cookbook/*/*.cabal
doc/cookbook/basic-auth
doc/cookbook/db-postgres-pool
doc/cookbook/db-sqlite-simple
-- MkLink changed
-- doc/cookbook/file-upload
doc/cookbook/https
-- servant-auth-* doesn't support GHC-8.4
-- doc/cookbook/jwt-and-basic-auth
doc/cookbook/pagination
doc/cookbook/structuring-apis
doc/cookbook/using-custom-monad
allow-newer: allow-newer:
servant-js:servant,
servant-js:servant-foreign,
servant-auth-server:http-types, servant-auth-server:http-types,
servant-multipart:lens,
servant-multipart:resourcet,
servant-multipart:servant,
servant-multipart:servant-server,
servant-auth-server:servant-server servant-auth-server:servant-server
constraints: constraints:
-- see https://github.com/haskell-infra/hackage-trustees/issues/119 -- see https://github.com/haskell-infra/hackage-trustees/issues/119
foundation >=0.0.14, foundation >=0.0.14,
memory <0.14.12 || >0.14.12 memory <0.14.12 || >0.14.12
allow-newer:
http-media:base

2
doc/cookbook/basic-auth/basic-auth.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-basic-auth executable cookbook-basic-auth
main-is: BasicAuth.lhs main-is: BasicAuth.lhs

2
doc/cookbook/db-postgres-pool/db-postgres-pool.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-db-postgres-pool executable cookbook-db-postgres-pool
main-is: PostgresPool.lhs main-is: PostgresPool.lhs

2
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-db-sqlite-simple executable cookbook-db-sqlite-simple
main-is: DBConnection.lhs main-is: DBConnection.lhs

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

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-file-upload executable cookbook-file-upload
main-is: FileUpload.lhs main-is: FileUpload.lhs

2
doc/cookbook/https/https.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-https executable cookbook-https
main-is: Https.lhs main-is: Https.lhs

2
doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal
View file

@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com
category: Servant category: Servant
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-jwt-and-basic-auth executable cookbook-jwt-and-basic-auth
if !impl(ghc >= 7.10) if !impl(ghc >= 7.10)

5
doc/cookbook/pagination/dummy/Pagination.lhs Normal file
View file

@ -0,0 +1,5 @@
```haskell
module Main (main) where
main :: IO ()
main = return ()
```

26
doc/cookbook/pagination/pagination.cabal
View file

@ -8,17 +8,25 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
extra-source-files:
Pagination.lhs
dummy/Pagination.lhs
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-pagination executable cookbook-pagination
if impl(ghc < 7.10.1)
buildable: False
main-is: Pagination.lhs main-is: Pagination.lhs
build-depends: base == 4.* build-tool-depends: markdown-unlit:markdown-unlit
, aeson
, servant
, servant-server
, servant-pagination >= 2.1.0 && < 3.0.0
, warp
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit
if impl(ghc >= 8.0)
hs-source-dirs: .
build-depends: base >= 4.8 && <4.12
, aeson
, servant
, servant-server
, servant-pagination >= 2.1.0 && < 3.0.0
, warp
else
hs-source-dirs: dummy
build-depends: base

2
doc/cookbook/structuring-apis/structuring-apis.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-structuring-apis executable cookbook-structuring-apis
main-is: StructuringApis.lhs main-is: StructuringApis.lhs

2
doc/cookbook/using-custom-monad/using-custom-monad.cabal
View file

@ -8,7 +8,7 @@ author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
executable cookbook-using-custom-monad executable cookbook-using-custom-monad
main-is: UsingCustomMonad.lhs main-is: UsingCustomMonad.lhs

5
doc/examples.md
View file

@ -6,6 +6,11 @@
including a test-suite using [**hspec**](http://hspec.github.io/) and including a test-suite using [**hspec**](http://hspec.github.io/) and
**servant-client**. **servant-client**.
- **[servant-examples](https://github.com/sras/servant-examples)**:
Similar to [the cookbook](https://haskell-servant.readthedocs.io/en/latest/cookbook/index.html) but
with no explanations, for developers who just want to look at code examples to find out how to do X or Y
with servant.
- **[stack-templates](https://github.com/commercialhaskell/stack-templates)** - **[stack-templates](https://github.com/commercialhaskell/stack-templates)**

2
doc/tutorial/ApiType.lhs
View file

@ -137,7 +137,7 @@ type StreamGet = Stream 'GET
type StreamPost = Stream 'POST type StreamPost = Stream 'POST
``` ```
These describe endpoints that return a stream of values rather than just a single value. They not only take a single content type as a parameter, but also a framing strategy -- this specifies how the individual results are delineated from one another in the stream. The two standard strategies given with Servant are `NewlineFraming` and `NetstringFraming`, but others can be written to match other protocols. These describe endpoints that return a stream of values rather than just a single value. They not only take a single content type as a parameter, but also a framing strategy -- this specifies how the individual results are delineated from one another in the stream. The three standard strategies given with Servant are `NewlineFraming`, `NetstringFraming` and `NoFraming`, but others can be written to match other protocols.
### `Capture` ### `Capture`

6
doc/tutorial/Server.lhs
View file

@ -95,12 +95,6 @@ users1 =
] ]
``` ```
Let's also write our API type.
``` haskell ignore
type UserAPI1 = "users" :> Get '[JSON] [User]
```
We can now take care of writing the actual webservice that will handle requests We can now take care of writing the actual webservice that will handle requests
to such an API. This one will be very simple, being reduced to just a single to such an API. This one will be very simple, being reduced to just a single
endpoint. The type of the web application is determined by the API type, endpoint. The type of the web application is determined by the API type,

3
doc/tutorial/tutorial.cabal
View file

@ -17,6 +17,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.3
extra-source-files: extra-source-files:
static/index.html static/index.html
static/ui.js static/ui.js
@ -34,7 +35,7 @@ library
-- Packages `servant` depends on. -- Packages `servant` depends on.
-- We don't need to specify bounds here as this package is never released. -- We don't need to specify bounds here as this package is never released.
build-depends: build-depends:
base >= 4.7 && <4.11 base >= 4.7 && <4.12
, aeson , aeson
, aeson-compat , aeson-compat
, attoparsec , attoparsec

3
servant-client-core/servant-client-core.cabal
View file

@ -23,6 +23,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.3
source-repository head source-repository head
type: git type: git
@ -47,7 +48,7 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.12
, bytestring >= 0.10.4.0 && < 0.11 , bytestring >= 0.10.4.0 && < 0.11
, containers >= 0.5.5.1 && < 0.6 , containers >= 0.5.5.1 && < 0.6
, mtl >= 2.1 && < 2.3 , mtl >= 2.1 && < 2.3

4
servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs
View file

@ -285,9 +285,9 @@ instance OVERLAPPING_
instance OVERLAPPABLE_ instance OVERLAPPABLE_
( RunClient m, MimeUnrender ct a, ReflectMethod method, ( RunClient m, MimeUnrender ct a, ReflectMethod method,
FramingUnrender framing a, BuildFromStream a (f a) FramingUnrender framing a, BuildFromStream a (f a)
) => HasClient m (Stream method framing ct (f a)) where ) => HasClient m (Stream method status framing ct (f a)) where
type Client m (Stream method framing ct (f a)) = m (f a) type Client m (Stream method status framing ct (f a)) = m (f a)
clientWithRoute _pm Proxy req = do clientWithRoute _pm Proxy req = do
sresp <- streamingRequest req sresp <- streamingRequest req

2
servant-client-ghcjs/servant-client-ghcjs.cabal
View file

@ -31,7 +31,7 @@ library
Servant.Client.Ghcjs Servant.Client.Ghcjs
Servant.Client.Internal.XhrClient Servant.Client.Internal.XhrClient
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.12
, bytestring >= 0.10 && < 0.11 , bytestring >= 0.10 && < 0.11
, case-insensitive >= 1.2.0.0 && < 1.3.0.0 , case-insensitive >= 1.2.0.0 && < 1.3.0.0
, containers >= 0.5 && < 0.6 , containers >= 0.5 && < 0.6

5
servant-client/servant-client.cabal
View file

@ -21,6 +21,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.3
homepage: http://haskell-servant.readthedocs.org/ homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:
@ -41,7 +42,7 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.12
, bytestring >= 0.10.4.0 && < 0.11 , bytestring >= 0.10.4.0 && < 0.11
, containers >= 0.5.5.1 && < 0.6 , containers >= 0.5.5.1 && < 0.6
, mtl >= 2.1 && < 2.3 , mtl >= 2.1 && < 2.3
@ -121,7 +122,7 @@ test-suite spec
, hspec >= 2.4.4 && < 2.6 , hspec >= 2.4.4 && < 2.6
, HUnit >= 1.6 && < 1.7 , HUnit >= 1.6 && < 1.7
, random-bytestring >= 0.1 && < 0.2 , random-bytestring >= 0.1 && < 0.2
, network >= 2.6.3.2 && < 2.7 , network >= 2.6.3.2 && < 2.8
, QuickCheck >= 2.10.1 && < 2.12 , QuickCheck >= 2.10.1 && < 2.12
, servant == 0.13.* , servant == 0.13.*
, servant-server == 0.13.* , servant-server == 0.13.*

27
servant-client/test/Servant/StreamSpec.hs
View file

@ -29,7 +29,6 @@ module Servant.StreamSpec (spec) where
import Control.Monad (replicateM_, void) import Control.Monad (replicateM_, void)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import Data.Proxy import Data.Proxy
import GHC.Stats (currentBytesUsed, getGCStats)
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import Prelude () import Prelude ()
import Prelude.Compat import Prelude.Compat
@ -41,12 +40,18 @@ import Test.QuickCheck
import Servant.API ((:<|>) ((:<|>)), (:>), JSON, import Servant.API ((:<|>) ((:<|>)), (:>), JSON,
NetstringFraming, NewlineFraming, NetstringFraming, NewlineFraming,
OctetStream, ResultStream (..), OctetStream, ResultStream (..),
StreamGenerator (..), StreamGet) StreamGenerator (..), StreamGet,
NoFraming)
import Servant.Client import Servant.Client
import Servant.ClientSpec (Person (..)) import Servant.ClientSpec (Person (..))
import qualified Servant.ClientSpec as CS import qualified Servant.ClientSpec as CS
import Servant.Server import Servant.Server
#if MIN_VERSION_base(4,10,0)
import GHC.Stats (gcdetails_mem_in_use_bytes, gc, getRTSStats)
#else
import GHC.Stats (currentBytesUsed, getGCStats)
#endif
spec :: Spec spec :: Spec
spec = describe "Servant.Stream" $ do spec = describe "Servant.Stream" $ do
@ -55,7 +60,7 @@ spec = describe "Servant.Stream" $ do
type StreamApi f = type StreamApi f =
"streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person)
:<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person) :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person)
:<|> "streamALot" :> StreamGet NewlineFraming OctetStream (f BS.ByteString) :<|> "streamALot" :> StreamGet NoFraming OctetStream (f BS.ByteString)
capi :: Proxy (StreamApi ResultStream) capi :: Proxy (StreamApi ResultStream)
@ -81,16 +86,16 @@ server = serve sapi
:<|> return (StreamGenerator lotsGenerator) :<|> return (StreamGenerator lotsGenerator)
where where
lotsGenerator f r = do lotsGenerator f r = do
f "" void $ f ""
withFile "/dev/urandom" ReadMode $ void $ withFile "/dev/urandom" ReadMode $
\handle -> streamFiveMBNTimes handle 1000 r \handle -> streamFiveMBNTimes handle 1000 r
return () return ()
streamFiveMBNTimes handle left sink streamFiveMBNTimes handle left sink
| left <= 0 = return "" | left <= (0 :: Int) = return ()
| otherwise = do | otherwise = do
msg <- BS.hGet handle (megabytes 5) msg <- BS.hGet handle (megabytes 5)
sink msg _ <- sink msg
streamFiveMBNTimes handle (left - 1) sink streamFiveMBNTimes handle (left - 1) sink
@ -129,8 +134,12 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
Right (ResultStream res) <- runClient getGetALot baseUrl Right (ResultStream res) <- runClient getGetALot baseUrl
let consumeNChunks n = replicateM_ n (res void) let consumeNChunks n = replicateM_ n (res void)
consumeNChunks 900 consumeNChunks 900
#if MIN_VERSION_base(4,10,0)
memUsed <- gcdetails_mem_in_use_bytes . gc <$> getRTSStats
#else
memUsed <- currentBytesUsed <$> getGCStats memUsed <- currentBytesUsed <$> getGCStats
memUsed `shouldSatisfy` (< (megabytes 20)) #endif
memUsed `shouldSatisfy` (< megabytes 22)
megabytes :: Num a => a -> a megabytes :: Num a => a -> a
megabytes n = n * (1000 ^ 2) megabytes n = n * (1000 ^ (2 :: Int))

3
servant-docs/servant-docs.cabal
View file

@ -21,6 +21,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.3
homepage: http://haskell-servant.readthedocs.org/ homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:
@ -42,7 +43,7 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.12
, bytestring >= 0.10.4.0 && < 0.11 , bytestring >= 0.10.4.0 && < 0.11
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 1.3

5
servant-foreign/CHANGELOG.md
View file

@ -1,6 +1,11 @@
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md) [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md)
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
0.11.1
------
- Add missing `Semigroup` instances
0.11 0.11
---- ----

7
servant-foreign/servant-foreign.cabal
View file

@ -27,6 +27,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.3
source-repository head source-repository head
type: git type: git
@ -42,9 +43,13 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.7 && <4.11 base >= 4.7 && <4.12
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 1.3
if !impl(ghc >= 8.0)
build-depends:
semigroups >=0.18.3 && <0.19
-- Servant dependencies -- Servant dependencies
build-depends: build-depends:
servant == 0.13.* servant == 0.13.*

5
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -27,6 +27,7 @@ import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
(.~)) (.~))
import Data.Data (Data) import Data.Data (Data)
import Data.Proxy import Data.Proxy
import Data.Semigroup (Semigroup)
import Data.String import Data.String
import Data.Text import Data.Text
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
@ -38,12 +39,12 @@ import Servant.API.TypeLevel
import Servant.API.Modifiers (RequiredArgument) import Servant.API.Modifiers (RequiredArgument)
newtype FunctionName = FunctionName { unFunctionName :: [Text] } newtype FunctionName = FunctionName { unFunctionName :: [Text] }
deriving (Data, Show, Eq, Monoid, Typeable) deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)
makePrisms ''FunctionName makePrisms ''FunctionName
newtype PathSegment = PathSegment { unPathSegment :: Text } newtype PathSegment = PathSegment { unPathSegment :: Text }
deriving (Data, Show, Eq, IsString, Monoid, Typeable) deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)
makePrisms ''PathSegment makePrisms ''PathSegment

5
servant-server/servant-server.cabal
View file

@ -26,6 +26,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.3
extra-source-files: extra-source-files:
include/*.h include/*.h
CHANGELOG.md CHANGELOG.md
@ -60,7 +61,7 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.12
, bytestring >= 0.10.4.0 && < 0.11 , bytestring >= 0.10.4.0 && < 0.11
, containers >= 0.5.5.1 && < 0.6 , containers >= 0.5.5.1 && < 0.6
, mtl >= 2.1 && < 2.3 , mtl >= 2.1 && < 2.3
@ -90,7 +91,7 @@ library
, http-types >= 0.12 && < 0.13 , http-types >= 0.12 && < 0.13
, network-uri >= 2.6.1.0 && < 2.7 , network-uri >= 2.6.1.0 && < 2.7
, monad-control >= 1.0.0.4 && < 1.1 , monad-control >= 1.0.0.4 && < 1.1
, network >= 2.6.3.2 && < 2.7 , network >= 2.6.3.2 && < 2.8
, safe >= 0.3.15 && < 0.4 , safe >= 0.3.15 && < 0.4
, split >= 0.2.3.2 && < 0.3 , split >= 0.2.3.2 && < 0.3
, string-conversions >= 0.4.0.1 && < 0.5 , string-conversions >= 0.4.0.1 && < 0.5

35
servant-server/src/Servant/Server/Internal.hs
View file

@ -283,37 +283,40 @@ instance OVERLAPPING_
instance OVERLAPPABLE_ instance OVERLAPPABLE_
( MimeRender ctype a, ReflectMethod method, ( MimeRender ctype a, ReflectMethod method, KnownNat status,
FramingRender framing ctype, ToStreamGenerator f a FramingRender framing ctype, ToStreamGenerator b a
) => HasServer (Stream method framing ctype (f a)) context where ) => HasServer (Stream method status framing ctype b) context where
type ServerT (Stream method framing ctype (f a)) m = m (f a) type ServerT (Stream method status framing ctype b) m = m b
hoistServerWithContext _ _ nt s = nt s hoistServerWithContext _ _ nt s = nt s
route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
instance OVERLAPPING_ instance OVERLAPPING_
( MimeRender ctype a, ReflectMethod method, ( MimeRender ctype a, ReflectMethod method, KnownNat status,
FramingRender framing ctype, ToStreamGenerator f a, FramingRender framing ctype, ToStreamGenerator b a,
GetHeaders (Headers h (f a)) GetHeaders (Headers h b)
) => HasServer (Stream method framing ctype (Headers h (f a))) context where ) => HasServer (Stream method status framing ctype (Headers h b)) context where
type ServerT (Stream method framing ctype (Headers h (f a))) m = m (Headers h (f a)) type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b)
hoistServerWithContext _ _ nt s = nt s hoistServerWithContext _ _ nt s = nt s
route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype)
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) => streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) =>
(b -> ([(HeaderName, B.ByteString)], f a)) (c -> ([(HeaderName, B.ByteString)], b))
-> Method -> Method
-> Status
-> Proxy framing -> Proxy framing
-> Proxy ctype -> Proxy ctype
-> Delayed env (Handler b) -> Delayed env (Handler c)
-> Router env -> Router env
streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond -> streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond ->
let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request
cmediatype = NHM.matchAccept [contentType ctypeproxy] accH cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
accCheck = when (isNothing cmediatype) $ delayedFail err406 accCheck = when (isNothing cmediatype) $ delayedFail err406
@ -323,7 +326,7 @@ streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \
) env request respond $ \ output -> ) env request respond $ \ output ->
let (headers, fa) = splitHeaders output let (headers, fa) = splitHeaders output
k = getStreamGenerator . toStreamGenerator $ fa in k = getStreamGenerator . toStreamGenerator $ fa in
Route $ responseStream status200 (contentHeader : headers) $ \write flush -> do Route $ responseStream status (contentHeader : headers) $ \write flush -> do
write . BB.lazyByteString $ header framingproxy ctypeproxy write . BB.lazyByteString $ header framingproxy ctypeproxy
case boundary framingproxy ctypeproxy of case boundary framingproxy ctypeproxy of
BoundaryStrategyBracket f -> BoundaryStrategyBracket f ->

105
servant-server/test/Servant/ServerSpec.hs
View file

@ -17,57 +17,62 @@
module Servant.ServerSpec where module Servant.ServerSpec where
import Control.Monad (forM_, when, unless) import Control.Monad
import Control.Monad.Error.Class (MonadError (..)) (forM_, unless, when)
import Data.Aeson (FromJSON, ToJSON, decode', encode) import Control.Monad.Error.Class
import qualified Data.ByteString.Base64 as Base64 (MonadError (..))
import Data.Char (toUpper) import Data.Aeson
(FromJSON, ToJSON, decode', encode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import Data.Char
(toUpper)
import Data.Monoid import Data.Monoid
import Data.Proxy (Proxy (Proxy)) import Data.Proxy
import Data.String (fromString) (Proxy (Proxy))
import Data.String.Conversions (cs) import Data.String
import qualified Data.Text as T (fromString)
import GHC.Generics (Generic) import Data.String.Conversions
import Network.HTTP.Types (Status (..), hAccept, hContentType, (cs)
methodDelete, methodGet, import qualified Data.Text as T
methodHead, methodPatch, import GHC.Generics
methodPost, methodPut, ok200, (Generic)
imATeapot418, import Network.HTTP.Types
parseQuery) (Status (..), hAccept, hContentType, imATeapot418,
import Network.Wai (Application, Request, requestHeaders, pathInfo, methodDelete, methodGet, methodHead, methodPatch, methodPost,
queryString, rawQueryString, methodPut, ok200, parseQuery)
responseLBS) import Network.Wai
import Network.Wai.Test (defaultRequest, request, (Application, Request, pathInfo, queryString, rawQueryString,
runSession, simpleBody, requestHeaders, responseLBS)
simpleHeaders, simpleStatus) import Network.Wai.Test
import Servant.API ((:<|>) (..), (:>), AuthProtect, (defaultRequest, request, runSession, simpleBody,
BasicAuth, BasicAuthData(BasicAuthData), simpleHeaders, simpleStatus)
Capture, CaptureAll, Delete, Get, Header, import Servant.API
Headers, HttpVersion, ((:<|>) (..), (:>), AuthProtect, BasicAuth,
IsSecure (..), JSON, BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete,
NoContent (..), Patch, PlainText, EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
Post, Put, EmptyAPI, JSON, NoContent (..), NoFraming, OctetStream, Patch,
QueryFlag, QueryParam, QueryParams, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
Raw, RemoteHost, ReqBody, RemoteHost, ReqBody, StdMethod (..), Stream,
StdMethod (..), Verb, addHeader) StreamGenerator (..), Verb, addHeader)
import Servant.API.Internal.Test.ComprehensiveAPI import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Server (Server, Handler, Tagged (..), err401, err403, import Servant.Server
err404, serve, serveWithContext, (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
Context((:.), EmptyContext), emptyServer) emptyServer, err401, err403, err404, serve, serveWithContext)
import Test.Hspec (Spec, context, describe, it, import Test.Hspec
shouldBe, shouldContain) (Spec, context, describe, it, shouldBe, shouldContain)
import qualified Test.Hspec.Wai as THW import Test.Hspec.Wai
import Test.Hspec.Wai (get, liftIO, matchHeaders, (get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
matchStatus, shouldRespondWith, with, (<:>))
with, (<:>)) import qualified Test.Hspec.Wai as THW
import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),
BasicAuthResult(Authorized,Unauthorized))
import Servant.Server.Experimental.Auth import Servant.Server.Experimental.Auth
(AuthHandler, AuthServerData, (AuthHandler, AuthServerData, mkAuthHandler)
mkAuthHandler) import Servant.Server.Internal.BasicAuth
(BasicAuthCheck (BasicAuthCheck),
BasicAuthResult (Authorized, Unauthorized))
import Servant.Server.Internal.Context import Servant.Server.Internal.Context
(NamedContext(..)) (NamedContext (..))
-- * comprehensive api test -- * comprehensive api test
@ -105,6 +110,7 @@ type VerbApi method status
:<|> "accept" :> ( Verb method status '[JSON] Person :<|> "accept" :> ( Verb method status '[JSON] Person
:<|> Verb method status '[PlainText] String :<|> Verb method status '[PlainText] String
) )
:<|> "stream" :> Stream method status NoFraming OctetStream (StreamGenerator BS.ByteString)
verbSpec :: Spec verbSpec :: Spec
verbSpec = describe "Servant.API.Verb" $ do verbSpec = describe "Servant.API.Verb" $ do
@ -114,6 +120,8 @@ verbSpec = describe "Servant.API.Verb" $ do
:<|> return (addHeader 5 alice) :<|> return (addHeader 5 alice)
:<|> return (addHeader 10 NoContent) :<|> return (addHeader 10 NoContent)
:<|> (return alice :<|> return "B") :<|> (return alice :<|> return "B")
:<|> return (StreamGenerator $ \f _ -> f "bytestring")
get200 = Proxy :: Proxy (VerbApi 'GET 200) get200 = Proxy :: Proxy (VerbApi 'GET 200)
post210 = Proxy :: Proxy (VerbApi 'POST 210) post210 = Proxy :: Proxy (VerbApi 'POST 210)
put203 = Proxy :: Proxy (VerbApi 'PUT 203) put203 = Proxy :: Proxy (VerbApi 'PUT 203)
@ -179,6 +187,11 @@ verbSpec = describe "Servant.API.Verb" $ do
liftIO $ simpleHeaders response `shouldContain` liftIO $ simpleHeaders response `shouldContain`
[("Content-Type", "application/json;charset=utf-8")] [("Content-Type", "application/json;charset=utf-8")]
it "works for Stream as for Result" $ do
response <- THW.request method "/stream" [] ""
liftIO $ statusCode (simpleStatus response) `shouldBe` status
liftIO $ simpleBody response `shouldBe` "bytestring"
test "GET 200" get200 methodGet 200 test "GET 200" get200 methodGet 200
test "POST 210" post210 methodPost 210 test "POST 210" post210 methodPost 210
test "PUT 203" put203 methodPut 203 test "PUT 203" put203 methodPut 203

3
servant/servant.cabal
View file

@ -22,6 +22,7 @@ tested-with:
GHC==7.10.3 GHC==7.10.3
GHC==8.0.2 GHC==8.0.2
GHC==8.2.2 GHC==8.2.2
GHC==8.4.3
extra-source-files: extra-source-files:
include/*.h include/*.h
CHANGELOG.md CHANGELOG.md
@ -69,7 +70,7 @@ library
-- --
-- note: mtl lower bound is so low because of GHC-7.8 -- note: mtl lower bound is so low because of GHC-7.8
build-depends: build-depends:
base >= 4.7 && < 4.11 base >= 4.7 && < 4.12
, bytestring >= 0.10.4.0 && < 0.11 , bytestring >= 0.10.4.0 && < 0.11
, mtl >= 2.1 && < 2.3 , mtl >= 2.1 && < 2.3
, text >= 1.2.3.0 && < 1.3 , text >= 1.2.3.0 && < 1.3

4
servant/src/Servant/API.hs
View file

@ -117,8 +117,8 @@ import Servant.API.Stream
(BoundaryStrategy (..), BuildFromStream (..), (BoundaryStrategy (..), BuildFromStream (..),
ByteStringParser (..), FramingRender (..), ByteStringParser (..), FramingRender (..),
FramingUnrender (..), NetstringFraming, NewlineFraming, FramingUnrender (..), NetstringFraming, NewlineFraming,
ResultStream (..), Stream, StreamGenerator (..), StreamGet, NoFraming, ResultStream (..), Stream, StreamGenerator (..),
StreamPost, ToStreamGenerator (..)) StreamGet, StreamPost, ToStreamGenerator (..))
import Servant.API.Sub import Servant.API.Sub
((:>)) ((:>))
import Servant.API.Vault import Servant.API.Vault

46
servant/src/Servant/API/ResponseHeaders.hs
View file

@ -100,23 +100,41 @@ instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
class GetHeaders ls where class GetHeaders ls where
getHeaders :: ls -> [HTTP.Header] getHeaders :: ls -> [HTTP.Header]
instance OVERLAPPING_ GetHeaders (HList '[]) where -- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance
getHeaders _ = [] class GetHeadersFromHList hs where
getHeadersFromHList :: HList hs -> [HTTP.Header]
instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) ) instance GetHeadersFromHList hs => GetHeaders (HList hs) where
=> GetHeaders (HList (Header h x ': xs)) where getHeaders = getHeadersFromHList
getHeaders hdrs = case hdrs of
Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest
UndecodableHeader h `HCons` rest -> (headerName, h) :getHeaders rest
MissingHeader `HCons` rest -> getHeaders rest
where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
instance OVERLAPPING_ GetHeaders (Headers '[] a) where instance GetHeadersFromHList '[] where
getHeaders _ = [] getHeadersFromHList _ = []
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v ) instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)
=> GetHeaders (Headers (Header h v ': rest) a) where => GetHeadersFromHList (Header h x ': xs)
getHeaders hs = getHeaders $ getHeadersHList hs where
getHeadersFromHList hdrs = case hdrs of
Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest
UndecodableHeader h `HCons` rest -> (headerName, h) : getHeadersFromHList rest
MissingHeader `HCons` rest -> getHeadersFromHList rest
where
headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h)
-- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance
class GetHeaders' hs where
getHeaders' :: Headers hs a -> [HTTP.Header]
instance GetHeaders' hs => GetHeaders (Headers hs a) where
getHeaders = getHeaders'
-- | This instance is an optimisation
instance GetHeaders' '[] where
getHeaders' _ = []
instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v)
=> GetHeaders' (Header h v ': rest)
where
getHeaders' hs = getHeadersFromHList $ getHeadersHList hs
-- * Adding -- * Adding

31
servant/src/Servant/API/Stream.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-} {-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -25,26 +26,28 @@ import Data.Typeable
(Typeable) (Typeable)
import GHC.Generics import GHC.Generics
(Generic) (Generic)
import GHC.TypeLits
(Nat)
import Network.HTTP.Types.Method import Network.HTTP.Types.Method
(StdMethod (..)) (StdMethod (..))
import Text.Read import Text.Read
(readMaybe) (readMaybe)
-- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Steam endpoints always return response code 200 on success. Type synonyms are provided for standard methods. -- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Stream endpoints always return response code 200 on success. Type synonyms are provided for standard methods.
data Stream (method :: k1) (framing :: *) (contentType :: *) (a :: *) data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
deriving (Typeable, Generic) deriving (Typeable, Generic)
type StreamGet = Stream 'GET type StreamGet = Stream 'GET 200
type StreamPost = Stream 'POST type StreamPost = Stream 'POST 200
-- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation). -- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation).
newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()} newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()}
-- | ToStreamGenerator is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly as endpoints. -- | ToStreamGenerator is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly as endpoints.
class ToStreamGenerator f a where class ToStreamGenerator a b | a -> b where
toStreamGenerator :: f a -> StreamGenerator a toStreamGenerator :: a -> StreamGenerator b
instance ToStreamGenerator StreamGenerator a instance ToStreamGenerator (StreamGenerator a) a
where toStreamGenerator x = x where toStreamGenerator x = x
-- | Clients reading from streaming endpoints can be implemented as producing a @ResultStream@ that captures the setup, takedown, and incremental logic for a read, being an IO continuation that takes a producer of Just either values or errors that terminates with a Nothing. -- | Clients reading from streaming endpoints can be implemented as producing a @ResultStream@ that captures the setup, takedown, and incremental logic for a read, being an IO continuation that takes a producer of Just either values or errors that terminates with a Nothing.
@ -80,6 +83,18 @@ data ByteStringParser a = ByteStringParser {
class FramingUnrender strategy a where class FramingUnrender strategy a where
unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString)) unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString))
-- | A framing strategy that does not do any framing at all, it just passes the input data
-- This will be used most of the time with binary data, such as files
data NoFraming
instance FramingRender NoFraming a where
header _ _ = empty
boundary _ _ = BoundaryStrategyGeneral id
trailer _ _ = empty
instance FramingUnrender NoFraming a where
unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,)
where go = ByteStringParser (Just . (, empty) . Right) ((, empty) . Right)
-- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame. -- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame.
-- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON). -- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON).

196
servant/src/Servant/Utils/Links.hs
View file

@ -19,8 +19,6 @@
-- >>> import Servant.Utils.Links -- >>> import Servant.Utils.Links
-- >>> import Data.Proxy -- >>> import Data.Proxy
-- >>> -- >>>
-- >>>
-- >>>
-- >>> type Hello = "hello" :> Get '[JSON] Int -- >>> type Hello = "hello" :> Get '[JSON] Int
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent -- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
-- >>> type API = Hello :<|> Bye -- >>> type API = Hello :<|> Bye
@ -63,10 +61,24 @@
-- >>> :set -XConstraintKinds -- >>> :set -XConstraintKinds
-- >>> :{ -- >>> :{
-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) -- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
-- >>> => Proxy endpoint -> MkLink endpoint -- >>> => Proxy endpoint -> MkLink endpoint Link
-- >>> apiLink = safeLink api -- >>> apiLink = safeLink api
-- >>> :} -- >>> :}
-- --
-- `safeLink'` allows to make specialise the output:
--
-- >>> safeLink' toUrlPiece api without
-- "bye"
--
-- >>> :{
-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
-- >>> => Proxy endpoint -> MkLink endpoint Text
-- >>> apiTextLink = safeLink' toUrlPiece api
-- >>> :}
--
-- >>> apiTextLink without
-- "bye"
--
-- Attempting to construct a link to an endpoint that does not exist in api -- Attempting to construct a link to an endpoint that does not exist in api
-- will result in a type error like this: -- will result in a type error like this:
-- --
@ -86,7 +98,9 @@ module Servant.Utils.Links (
-- --
-- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
safeLink safeLink
, safeLink'
, allLinks , allLinks
, allLinks'
, URI(..) , URI(..)
-- * Adding custom types -- * Adding custom types
, HasLink(..) , HasLink(..)
@ -276,8 +290,18 @@ safeLink
:: forall endpoint api. (IsElem endpoint api, HasLink endpoint) :: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
=> Proxy api -- ^ The whole API that this endpoint is a part of => Proxy api -- ^ The whole API that this endpoint is a part of
-> Proxy endpoint -- ^ The API endpoint you would like to point to -> Proxy endpoint -- ^ The API endpoint you would like to point to
-> MkLink endpoint -> MkLink endpoint Link
safeLink _ endpoint = toLink endpoint (Link mempty mempty) safeLink = safeLink' id
-- | More general 'safeLink'.
--
safeLink'
:: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
=> (Link -> a)
-> Proxy api -- ^ The whole API that this endpoint is a part of
-> Proxy endpoint -- ^ The API endpoint you would like to point to
-> MkLink endpoint a
safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
-- | Create all links in an API. -- | Create all links in an API.
-- --
@ -293,37 +317,47 @@ safeLink _ endpoint = toLink endpoint (Link mempty mempty)
-- --
-- Note: nested APIs don't work well with this approach -- Note: nested APIs don't work well with this approach
-- --
-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) -- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) :: * -- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
-- = Char -> (Int -> Link) :<|> (Double -> Link) -- = Char -> (Int -> Link) :<|> (Double -> Link)
--
allLinks allLinks
:: forall api. HasLink api :: forall api. HasLink api
=> Proxy api => Proxy api
-> MkLink api -> MkLink api Link
allLinks api = toLink api (Link mempty mempty) allLinks = allLinks' id
-- | More general 'allLinks'. See `safeLink'`.
allLinks'
:: forall api a. HasLink api
=> (Link -> a)
-> Proxy api
-> MkLink api a
allLinks' toA api = toLink toA api (Link mempty mempty)
-- | Construct a toLink for an endpoint. -- | Construct a toLink for an endpoint.
class HasLink endpoint where class HasLink endpoint where
type MkLink endpoint type MkLink endpoint (a :: *)
toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to toLink
-> Link :: (Link -> a)
-> MkLink endpoint -> Proxy endpoint -- ^ The API endpoint you would like to point to
-> Link
-> MkLink endpoint a
-- Naked symbol instance -- Naked symbol instance
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
type MkLink (sym :> sub) = MkLink sub type MkLink (sym :> sub) a = MkLink sub a
toLink _ = toLink toA _ =
toLink (Proxy :: Proxy sub) . addSegment (escaped seg) toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
where where
seg = symbolVal (Proxy :: Proxy sym) seg = symbolVal (Proxy :: Proxy sym)
-- QueryParam instances -- QueryParam instances
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods)) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
=> HasLink (QueryParam' mods sym v :> sub) where => HasLink (QueryParam' mods sym v :> sub)
type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub where
toLink _ l mv = type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l mv =
toLink toA (Proxy :: Proxy sub) $
case sbool :: SBool (FoldRequired mods) of case sbool :: SBool (FoldRequired mods) of
STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
@ -332,105 +366,121 @@ instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mo
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
=> HasLink (QueryParams sym v :> sub) where => HasLink (QueryParams sym v :> sub)
type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub where
toLink _ l = type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
toLink (Proxy :: Proxy sub) . toLink toA _ l =
toLink toA (Proxy :: Proxy sub) .
foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
where where
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, HasLink sub) instance (KnownSymbol sym, HasLink sub)
=> HasLink (QueryFlag sym :> sub) where => HasLink (QueryFlag sym :> sub)
type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub where
toLink _ l False = type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
toLink (Proxy :: Proxy sub) l toLink toA _ l False =
toLink _ l True = toLink toA (Proxy :: Proxy sub) l
toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l toLink toA _ l True =
toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
where where
k = symbolVal (Proxy :: Proxy sym) k = symbolVal (Proxy :: Proxy sym)
-- :<|> instance - Generate all links at once -- :<|> instance - Generate all links at once
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
type MkLink (a :<|> b) = MkLink a :<|> MkLink b type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
-- Misc instances -- Misc instances
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
type MkLink (ReqBody' mods ct a :> sub) = MkLink sub type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink toA _ = toLink toA (Proxy :: Proxy sub)
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
=> HasLink (Capture' mods sym v :> sub) where => HasLink (Capture' mods sym v :> sub)
type MkLink (Capture' mods sym v :> sub) = v -> MkLink sub where
toLink _ l v = type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l v =
toLink toA (Proxy :: Proxy sub) $
addSegment (escaped . Text.unpack $ toUrlPiece v) l addSegment (escaped . Text.unpack $ toUrlPiece v) l
instance (ToHttpApiData v, HasLink sub) instance (ToHttpApiData v, HasLink sub)
=> HasLink (CaptureAll sym v :> sub) where => HasLink (CaptureAll sym v :> sub)
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub where
toLink _ l vs = type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
toLink (Proxy :: Proxy sub) $ toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
instance HasLink sub => HasLink (Header' mods sym a :> sub) where instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
type MkLink (Header' mods sym a :> sub) = MkLink sub type MkLink (Header' mods sym a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Vault :> sub) where instance HasLink sub => HasLink (Vault :> sub) where
type MkLink (Vault :> sub) = MkLink sub type MkLink (Vault :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Description s :> sub) where instance HasLink sub => HasLink (Description s :> sub) where
type MkLink (Description s :> sub) = MkLink sub type MkLink (Description s :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (Summary s :> sub) where instance HasLink sub => HasLink (Summary s :> sub) where
type MkLink (Summary s :> sub) = MkLink sub type MkLink (Summary s :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (HttpVersion :> sub) where instance HasLink sub => HasLink (HttpVersion :> sub) where
type MkLink (HttpVersion:> sub) = MkLink sub type MkLink (HttpVersion:> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (IsSecure :> sub) where instance HasLink sub => HasLink (IsSecure :> sub) where
type MkLink (IsSecure :> sub) = MkLink sub type MkLink (IsSecure :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (WithNamedContext name context sub) where instance HasLink sub => HasLink (WithNamedContext name context sub) where
type MkLink (WithNamedContext name context sub) = MkLink sub type MkLink (WithNamedContext name context sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink toA _ = toLink toA (Proxy :: Proxy sub)
instance HasLink sub => HasLink (RemoteHost :> sub) where instance HasLink sub => HasLink (RemoteHost :> sub) where
type MkLink (RemoteHost :> sub) = MkLink sub type MkLink (RemoteHost :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
type MkLink (BasicAuth realm a :> sub) = MkLink sub type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
instance HasLink EmptyAPI where instance HasLink EmptyAPI where
type MkLink EmptyAPI = EmptyAPI type MkLink EmptyAPI a = EmptyAPI
toLink _ _ = EmptyAPI toLink _ _ _ = EmptyAPI
-- Verb (terminal) instances -- Verb (terminal) instances
instance HasLink (Verb m s ct a) where instance HasLink (Verb m s ct a) where
type MkLink (Verb m s ct a) = Link type MkLink (Verb m s ct a) r = r
toLink _ = id toLink toA _ = toA
instance HasLink Raw where instance HasLink Raw where
type MkLink Raw = Link type MkLink Raw a = a
toLink _ = id toLink toA _ = toA
instance HasLink (Stream m fr ct a) where instance HasLink (Stream m fr ct a) where
type MkLink (Stream m fr ct a) = Link type MkLink (Stream m fr ct a) r = r
toLink _ = id toLink toA _ = toA
-- AuthProtext instances -- AuthProtext instances
instance HasLink sub => HasLink (AuthProtect tag :> sub) where instance HasLink sub => HasLink (AuthProtect tag :> sub) where
type MkLink (AuthProtect tag :> sub) = MkLink sub type MkLink (AuthProtect tag :> sub) a = MkLink sub a
toLink _ = toLink (Proxy :: Proxy sub) toLink = simpleToLink (Proxy :: Proxy sub)
-- | Helper for implemneting 'toLink' for combinators not affecting link
-- structure.
simpleToLink
:: forall sub a combinator.
(HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
=> Proxy sub
-> (Link -> a)
-> Proxy (combinator :> sub)
-> Link
-> MkLink (combinator :> sub) a
simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
-- $setup -- $setup
-- >>> import Servant.API -- >>> import Servant.API

2
servant/test/Servant/Utils/LinksSpec.hs
View file

@ -41,7 +41,7 @@ type LinkableApi =
apiLink :: (IsElem endpoint TestApi, HasLink endpoint) apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
=> Proxy endpoint -> MkLink endpoint => Proxy endpoint -> MkLink endpoint Link
apiLink = safeLink (Proxy :: Proxy TestApi) apiLink = safeLink (Proxy :: Proxy TestApi)
-- | Convert a link to a URI and ensure that this maps to the given string -- | Convert a link to a URI and ensure that this maps to the given string