Merge branch 'master' into 309-handle-application-exceptions-with-500-errors
This commit is contained in:
Sasa Bogicevic
commit
64686f3ec9
34 changed files with 404 additions and 248 deletions
77
.travis.yml
77
.travis.yml
|
|
@ -1,6 +1,6 @@
|
|||
# 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
|
||||
#
|
||||
|
|
@ -33,18 +33,21 @@ before_cache:
|
|||
|
||||
matrix:
|
||||
include:
|
||||
- compiler: "ghc-7.8.4"
|
||||
- compiler: "ghc-8.4.3"
|
||||
# env: TEST=--disable-tests BENCH=--disable-benchmarks
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], 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]}}
|
||||
addons: {apt: {packages: [ghc-ppa-tools,ghc-8.4.3], sources: [hvr-ghc]}}
|
||||
- compiler: "ghc-8.2.2"
|
||||
# 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:
|
||||
- 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/') ))
|
||||
- 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:
|
||||
- cabal --version
|
||||
- echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
|
||||
|
|
@ -64,15 +78,14 @@ install:
|
|||
- HADDOCK=${HADDOCK-true}
|
||||
- INSTALLED=${INSTALLED-true}
|
||||
- GHCHEAD=${GHCHEAD-false}
|
||||
- CABALNEWBUILDOPTS=--max-backjumps=10000
|
||||
- travis_retry cabal update -v
|
||||
- "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
|
||||
- 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"
|
||||
- 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 '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
|
||||
- if [ -f "servant/configure.ac" ]; then
|
||||
(cd "servant" && autoreconf -i);
|
||||
|
|
@ -95,32 +108,29 @@ install:
|
|||
- if [ -f "doc/tutorial/configure.ac" ]; then
|
||||
(cd "doc/tutorial" && autoreconf -i);
|
||||
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
|
||||
(cd "doc/cookbook/db-postgres-pool" && autoreconf -i);
|
||||
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
|
||||
(cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);
|
||||
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
|
||||
(cd "doc/cookbook/https" && autoreconf -i);
|
||||
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
|
||||
(cd "doc/cookbook/structuring-apis" && autoreconf -i);
|
||||
fi
|
||||
- if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then
|
||||
(cd "doc/cookbook/using-custom-monad" && autoreconf -i);
|
||||
fi
|
||||
- if [ -f "doc/cookbook/file-upload/configure.ac" ]; then
|
||||
(cd "doc/cookbook/file-upload" && autoreconf -i);
|
||||
fi
|
||||
- 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)
|
||||
|
||||
# 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-server" && 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/db-postgres-pool" && cabal sdist)
|
||||
- (cd "doc/cookbook/db-sqlite-simple" && cabal sdist)
|
||||
- (cd "doc/cookbook/https" && cabal sdist)
|
||||
- (cd "doc/cookbook/pagination" && cabal sdist)
|
||||
- (cd "doc/cookbook/structuring-apis" && 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 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
|
||||
- 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 '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
|
||||
- echo -en 'travis_fold:end:unpack\\r'
|
||||
|
||||
|
||||
- echo Building with tests and benchmarks... && echo -en 'travis_fold:start:build-everything\\r'
|
||||
# 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'
|
||||
- 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'
|
||||
# haddock
|
||||
- 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'
|
||||
# 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
|
||||
|
|
|
|||
|
|
@ -5,19 +5,29 @@ packages: servant/
|
|||
servant-foreign/
|
||||
servant-server/
|
||||
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:
|
||||
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
|
||||
|
||||
constraints:
|
||||
-- see https://github.com/haskell-infra/hackage-trustees/issues/119
|
||||
foundation >=0.0.14,
|
||||
memory <0.14.12 || >0.14.12
|
||||
|
||||
allow-newer:
|
||||
http-media:base
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
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
|
||||
main-is: BasicAuth.lhs
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC==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
|
||||
main-is: PostgresPool.lhs
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC==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
|
||||
main-is: DBConnection.lhs
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC==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
|
||||
main-is: FileUpload.lhs
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC==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
|
||||
main-is: Https.lhs
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com
|
|||
category: Servant
|
||||
build-type: Simple
|
||||
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
|
||||
if !impl(ghc >= 7.10)
|
||||
|
|
|
|||
5
doc/cookbook/pagination/dummy/Pagination.lhs
Normal file
5
doc/cookbook/pagination/dummy/Pagination.lhs
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
```haskell
|
||||
module Main (main) where
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
```
|
||||
|
|
@ -8,17 +8,25 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
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
|
||||
if impl(ghc < 7.10.1)
|
||||
buildable: False
|
||||
main-is: Pagination.lhs
|
||||
build-depends: base == 4.*
|
||||
build-tool-depends: markdown-unlit:markdown-unlit
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -pgmL 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
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -pgmL markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit
|
||||
else
|
||||
hs-source-dirs: dummy
|
||||
build-depends: base
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
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
|
||||
main-is: StructuringApis.lhs
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ author: Servant Contributors
|
|||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
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
|
||||
main-is: UsingCustomMonad.lhs
|
||||
|
|
|
|||
|
|
@ -6,6 +6,11 @@
|
|||
including a test-suite using [**hspec**](http://hspec.github.io/) and
|
||||
**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)**
|
||||
|
||||
|
|
|
|||
|
|
@ -137,7 +137,7 @@ type StreamGet = Stream 'GET
|
|||
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`
|
||||
|
|
|
|||
|
|
@ -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
|
||||
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,
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ tested-with:
|
|||
GHC==7.10.3
|
||||
GHC==8.0.2
|
||||
GHC==8.2.2
|
||||
GHC==8.4.3
|
||||
extra-source-files:
|
||||
static/index.html
|
||||
static/ui.js
|
||||
|
|
@ -34,7 +35,7 @@ library
|
|||
-- Packages `servant` depends on.
|
||||
-- We don't need to specify bounds here as this package is never released.
|
||||
build-depends:
|
||||
base >= 4.7 && <4.11
|
||||
base >= 4.7 && <4.12
|
||||
, aeson
|
||||
, aeson-compat
|
||||
, attoparsec
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ tested-with:
|
|||
GHC==7.10.3
|
||||
GHC==8.0.2
|
||||
GHC==8.2.2
|
||||
GHC==8.4.3
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
|
@ -47,7 +48,7 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
base >= 4.7 && < 4.12
|
||||
, bytestring >= 0.10.4.0 && < 0.11
|
||||
, containers >= 0.5.5.1 && < 0.6
|
||||
, mtl >= 2.1 && < 2.3
|
||||
|
|
|
|||
|
|
@ -285,9 +285,9 @@ instance OVERLAPPING_
|
|||
instance OVERLAPPABLE_
|
||||
( RunClient m, MimeUnrender ct a, ReflectMethod method,
|
||||
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
|
||||
sresp <- streamingRequest req
|
||||
|
|
|
|||
|
|
@ -31,7 +31,7 @@ library
|
|||
Servant.Client.Ghcjs
|
||||
Servant.Client.Internal.XhrClient
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
base >= 4.7 && < 4.12
|
||||
, bytestring >= 0.10 && < 0.11
|
||||
, case-insensitive >= 1.2.0.0 && < 1.3.0.0
|
||||
, containers >= 0.5 && < 0.6
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ tested-with:
|
|||
GHC==7.10.3
|
||||
GHC==8.0.2
|
||||
GHC==8.2.2
|
||||
GHC==8.4.3
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
Bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
extra-source-files:
|
||||
|
|
@ -41,7 +42,7 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
base >= 4.7 && < 4.12
|
||||
, bytestring >= 0.10.4.0 && < 0.11
|
||||
, containers >= 0.5.5.1 && < 0.6
|
||||
, mtl >= 2.1 && < 2.3
|
||||
|
|
@ -121,7 +122,7 @@ test-suite spec
|
|||
, hspec >= 2.4.4 && < 2.6
|
||||
, HUnit >= 1.6 && < 1.7
|
||||
, 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
|
||||
, servant == 0.13.*
|
||||
, servant-server == 0.13.*
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@ module Servant.StreamSpec (spec) where
|
|||
import Control.Monad (replicateM_, void)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Proxy
|
||||
import GHC.Stats (currentBytesUsed, getGCStats)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
|
@ -41,12 +40,18 @@ import Test.QuickCheck
|
|||
import Servant.API ((:<|>) ((:<|>)), (:>), JSON,
|
||||
NetstringFraming, NewlineFraming,
|
||||
OctetStream, ResultStream (..),
|
||||
StreamGenerator (..), StreamGet)
|
||||
StreamGenerator (..), StreamGet,
|
||||
NoFraming)
|
||||
import Servant.Client
|
||||
import Servant.ClientSpec (Person (..))
|
||||
import qualified Servant.ClientSpec as CS
|
||||
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 = describe "Servant.Stream" $ do
|
||||
|
|
@ -55,7 +60,7 @@ spec = describe "Servant.Stream" $ do
|
|||
type StreamApi f =
|
||||
"streamGetNewline" :> StreamGet NewlineFraming 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)
|
||||
|
|
@ -81,16 +86,16 @@ server = serve sapi
|
|||
:<|> return (StreamGenerator lotsGenerator)
|
||||
where
|
||||
lotsGenerator f r = do
|
||||
f ""
|
||||
withFile "/dev/urandom" ReadMode $
|
||||
void $ f ""
|
||||
void $ withFile "/dev/urandom" ReadMode $
|
||||
\handle -> streamFiveMBNTimes handle 1000 r
|
||||
return ()
|
||||
|
||||
streamFiveMBNTimes handle left sink
|
||||
| left <= 0 = return ""
|
||||
| left <= (0 :: Int) = return ()
|
||||
| otherwise = do
|
||||
msg <- BS.hGet handle (megabytes 5)
|
||||
sink msg
|
||||
_ <- sink msg
|
||||
streamFiveMBNTimes handle (left - 1) sink
|
||||
|
||||
|
||||
|
|
@ -129,8 +134,12 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
|
|||
Right (ResultStream res) <- runClient getGetALot baseUrl
|
||||
let consumeNChunks n = replicateM_ n (res void)
|
||||
consumeNChunks 900
|
||||
#if MIN_VERSION_base(4,10,0)
|
||||
memUsed <- gcdetails_mem_in_use_bytes . gc <$> getRTSStats
|
||||
#else
|
||||
memUsed <- currentBytesUsed <$> getGCStats
|
||||
memUsed `shouldSatisfy` (< (megabytes 20))
|
||||
#endif
|
||||
memUsed `shouldSatisfy` (< megabytes 22)
|
||||
|
||||
megabytes :: Num a => a -> a
|
||||
megabytes n = n * (1000 ^ 2)
|
||||
megabytes n = n * (1000 ^ (2 :: Int))
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ tested-with:
|
|||
GHC==7.10.3
|
||||
GHC==8.0.2
|
||||
GHC==8.2.2
|
||||
GHC==8.4.3
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
Bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
extra-source-files:
|
||||
|
|
@ -42,7 +43,7 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
base >= 4.7 && < 4.12
|
||||
, bytestring >= 0.10.4.0 && < 0.11
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
[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
|
||||
----
|
||||
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ tested-with:
|
|||
GHC==7.10.3
|
||||
GHC==8.0.2
|
||||
GHC==8.2.2
|
||||
GHC==8.4.3
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
|
@ -42,9 +43,13 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.7 && <4.11
|
||||
base >= 4.7 && <4.12
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends:
|
||||
semigroups >=0.18.3 && <0.19
|
||||
|
||||
-- Servant dependencies
|
||||
build-depends:
|
||||
servant == 0.13.*
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
|
|||
(.~))
|
||||
import Data.Data (Data)
|
||||
import Data.Proxy
|
||||
import Data.Semigroup (Semigroup)
|
||||
import Data.String
|
||||
import Data.Text
|
||||
import Data.Typeable (Typeable)
|
||||
|
|
@ -38,12 +39,12 @@ import Servant.API.TypeLevel
|
|||
import Servant.API.Modifiers (RequiredArgument)
|
||||
|
||||
newtype FunctionName = FunctionName { unFunctionName :: [Text] }
|
||||
deriving (Data, Show, Eq, Monoid, Typeable)
|
||||
deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)
|
||||
|
||||
makePrisms ''FunctionName
|
||||
|
||||
newtype PathSegment = PathSegment { unPathSegment :: Text }
|
||||
deriving (Data, Show, Eq, IsString, Monoid, Typeable)
|
||||
deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)
|
||||
|
||||
makePrisms ''PathSegment
|
||||
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@ tested-with:
|
|||
GHC==7.10.3
|
||||
GHC==8.0.2
|
||||
GHC==8.2.2
|
||||
GHC==8.4.3
|
||||
extra-source-files:
|
||||
include/*.h
|
||||
CHANGELOG.md
|
||||
|
|
@ -60,7 +61,7 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
base >= 4.7 && < 4.12
|
||||
, bytestring >= 0.10.4.0 && < 0.11
|
||||
, containers >= 0.5.5.1 && < 0.6
|
||||
, mtl >= 2.1 && < 2.3
|
||||
|
|
@ -90,7 +91,7 @@ library
|
|||
, http-types >= 0.12 && < 0.13
|
||||
, network-uri >= 2.6.1.0 && < 2.7
|
||||
, 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
|
||||
, split >= 0.2.3.2 && < 0.3
|
||||
, string-conversions >= 0.4.0.1 && < 0.5
|
||||
|
|
|
|||
|
|
@ -283,37 +283,40 @@ instance OVERLAPPING_
|
|||
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
( MimeRender ctype a, ReflectMethod method,
|
||||
FramingRender framing ctype, ToStreamGenerator f a
|
||||
) => HasServer (Stream method framing ctype (f a)) context where
|
||||
( MimeRender ctype a, ReflectMethod method, KnownNat status,
|
||||
FramingRender framing ctype, ToStreamGenerator b a
|
||||
) => 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
|
||||
|
||||
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)
|
||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
||||
|
||||
instance OVERLAPPING_
|
||||
( MimeRender ctype a, ReflectMethod method,
|
||||
FramingRender framing ctype, ToStreamGenerator f a,
|
||||
GetHeaders (Headers h (f a))
|
||||
) => HasServer (Stream method framing ctype (Headers h (f a))) context where
|
||||
( MimeRender ctype a, ReflectMethod method, KnownNat status,
|
||||
FramingRender framing ctype, ToStreamGenerator b a,
|
||||
GetHeaders (Headers h b)
|
||||
) => 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
|
||||
|
||||
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)
|
||||
status = toEnum . fromInteger $ natVal (Proxy :: Proxy status)
|
||||
|
||||
|
||||
streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) =>
|
||||
(b -> ([(HeaderName, B.ByteString)], f a))
|
||||
streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) =>
|
||||
(c -> ([(HeaderName, B.ByteString)], b))
|
||||
-> Method
|
||||
-> Status
|
||||
-> Proxy framing
|
||||
-> Proxy ctype
|
||||
-> Delayed env (Handler b)
|
||||
-> Delayed env (Handler c)
|
||||
-> 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
|
||||
cmediatype = NHM.matchAccept [contentType ctypeproxy] accH
|
||||
accCheck = when (isNothing cmediatype) $ delayedFail err406
|
||||
|
|
@ -323,7 +326,7 @@ streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \
|
|||
) env request respond $ \ output ->
|
||||
let (headers, fa) = splitHeaders output
|
||||
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
|
||||
case boundary framingproxy ctypeproxy of
|
||||
BoundaryStrategyBracket f ->
|
||||
|
|
|
|||
|
|
@ -17,57 +17,62 @@
|
|||
|
||||
module Servant.ServerSpec where
|
||||
|
||||
import Control.Monad (forM_, when, unless)
|
||||
import Control.Monad.Error.Class (MonadError (..))
|
||||
import Data.Aeson (FromJSON, ToJSON, decode', encode)
|
||||
import Control.Monad
|
||||
(forM_, unless, when)
|
||||
import Control.Monad.Error.Class
|
||||
(MonadError (..))
|
||||
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.Char
|
||||
(toUpper)
|
||||
import Data.Monoid
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.String (fromString)
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Data.String
|
||||
(fromString)
|
||||
import Data.String.Conversions
|
||||
(cs)
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Types (Status (..), hAccept, hContentType,
|
||||
methodDelete, methodGet,
|
||||
methodHead, methodPatch,
|
||||
methodPost, methodPut, ok200,
|
||||
imATeapot418,
|
||||
parseQuery)
|
||||
import Network.Wai (Application, Request, requestHeaders, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseLBS)
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody,
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import Network.HTTP.Types
|
||||
(Status (..), hAccept, hContentType, imATeapot418,
|
||||
methodDelete, methodGet, methodHead, methodPatch, methodPost,
|
||||
methodPut, ok200, parseQuery)
|
||||
import Network.Wai
|
||||
(Application, Request, pathInfo, queryString, rawQueryString,
|
||||
requestHeaders, responseLBS)
|
||||
import Network.Wai.Test
|
||||
(defaultRequest, request, runSession, simpleBody,
|
||||
simpleHeaders, simpleStatus)
|
||||
import Servant.API ((:<|>) (..), (:>), AuthProtect,
|
||||
BasicAuth, BasicAuthData(BasicAuthData),
|
||||
Capture, CaptureAll, Delete, Get, Header,
|
||||
Headers, HttpVersion,
|
||||
IsSecure (..), JSON,
|
||||
NoContent (..), Patch, PlainText,
|
||||
Post, Put, EmptyAPI,
|
||||
QueryFlag, QueryParam, QueryParams,
|
||||
Raw, RemoteHost, ReqBody,
|
||||
StdMethod (..), Verb, addHeader)
|
||||
import Servant.API
|
||||
((:<|>) (..), (:>), AuthProtect, BasicAuth,
|
||||
BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete,
|
||||
EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
|
||||
JSON, NoContent (..), NoFraming, OctetStream, Patch,
|
||||
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
|
||||
RemoteHost, ReqBody, StdMethod (..), Stream,
|
||||
StreamGenerator (..), Verb, addHeader)
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Server (Server, Handler, Tagged (..), err401, err403,
|
||||
err404, serve, serveWithContext,
|
||||
Context((:.), EmptyContext), emptyServer)
|
||||
import Test.Hspec (Spec, context, describe, it,
|
||||
shouldBe, shouldContain)
|
||||
import qualified Test.Hspec.Wai as THW
|
||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||
matchStatus, shouldRespondWith,
|
||||
import Servant.Server
|
||||
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
|
||||
emptyServer, err401, err403, err404, serve, serveWithContext)
|
||||
import Test.Hspec
|
||||
(Spec, context, describe, it, shouldBe, shouldContain)
|
||||
import Test.Hspec.Wai
|
||||
(get, liftIO, matchHeaders, matchStatus, shouldRespondWith,
|
||||
with, (<:>))
|
||||
import qualified Test.Hspec.Wai as THW
|
||||
|
||||
import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),
|
||||
BasicAuthResult(Authorized,Unauthorized))
|
||||
import Servant.Server.Experimental.Auth
|
||||
(AuthHandler, AuthServerData,
|
||||
mkAuthHandler)
|
||||
(AuthHandler, AuthServerData, mkAuthHandler)
|
||||
import Servant.Server.Internal.BasicAuth
|
||||
(BasicAuthCheck (BasicAuthCheck),
|
||||
BasicAuthResult (Authorized, Unauthorized))
|
||||
import Servant.Server.Internal.Context
|
||||
(NamedContext(..))
|
||||
(NamedContext (..))
|
||||
|
||||
-- * comprehensive api test
|
||||
|
||||
|
|
@ -105,6 +110,7 @@ type VerbApi method status
|
|||
:<|> "accept" :> ( Verb method status '[JSON] Person
|
||||
:<|> Verb method status '[PlainText] String
|
||||
)
|
||||
:<|> "stream" :> Stream method status NoFraming OctetStream (StreamGenerator BS.ByteString)
|
||||
|
||||
verbSpec :: Spec
|
||||
verbSpec = describe "Servant.API.Verb" $ do
|
||||
|
|
@ -114,6 +120,8 @@ verbSpec = describe "Servant.API.Verb" $ do
|
|||
:<|> return (addHeader 5 alice)
|
||||
:<|> return (addHeader 10 NoContent)
|
||||
:<|> (return alice :<|> return "B")
|
||||
:<|> return (StreamGenerator $ \f _ -> f "bytestring")
|
||||
|
||||
get200 = Proxy :: Proxy (VerbApi 'GET 200)
|
||||
post210 = Proxy :: Proxy (VerbApi 'POST 210)
|
||||
put203 = Proxy :: Proxy (VerbApi 'PUT 203)
|
||||
|
|
@ -179,6 +187,11 @@ verbSpec = describe "Servant.API.Verb" $ do
|
|||
liftIO $ simpleHeaders response `shouldContain`
|
||||
[("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 "POST 210" post210 methodPost 210
|
||||
test "PUT 203" put203 methodPut 203
|
||||
|
|
|
|||
|
|
@ -22,6 +22,7 @@ tested-with:
|
|||
GHC==7.10.3
|
||||
GHC==8.0.2
|
||||
GHC==8.2.2
|
||||
GHC==8.4.3
|
||||
extra-source-files:
|
||||
include/*.h
|
||||
CHANGELOG.md
|
||||
|
|
@ -69,7 +70,7 @@ library
|
|||
--
|
||||
-- note: mtl lower bound is so low because of GHC-7.8
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.11
|
||||
base >= 4.7 && < 4.12
|
||||
, bytestring >= 0.10.4.0 && < 0.11
|
||||
, mtl >= 2.1 && < 2.3
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
|
|
|
|||
|
|
@ -117,8 +117,8 @@ import Servant.API.Stream
|
|||
(BoundaryStrategy (..), BuildFromStream (..),
|
||||
ByteStringParser (..), FramingRender (..),
|
||||
FramingUnrender (..), NetstringFraming, NewlineFraming,
|
||||
ResultStream (..), Stream, StreamGenerator (..), StreamGet,
|
||||
StreamPost, ToStreamGenerator (..))
|
||||
NoFraming, ResultStream (..), Stream, StreamGenerator (..),
|
||||
StreamGet, StreamPost, ToStreamGenerator (..))
|
||||
import Servant.API.Sub
|
||||
((:>))
|
||||
import Servant.API.Vault
|
||||
|
|
|
|||
|
|
@ -100,23 +100,41 @@ instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h )
|
|||
class GetHeaders ls where
|
||||
getHeaders :: ls -> [HTTP.Header]
|
||||
|
||||
instance OVERLAPPING_ GetHeaders (HList '[]) where
|
||||
getHeaders _ = []
|
||||
-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance
|
||||
class GetHeadersFromHList hs where
|
||||
getHeadersFromHList :: HList hs -> [HTTP.Header]
|
||||
|
||||
instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) )
|
||||
=> GetHeaders (HList (Header h x ': xs)) where
|
||||
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 GetHeadersFromHList hs => GetHeaders (HList hs) where
|
||||
getHeaders = getHeadersFromHList
|
||||
|
||||
instance OVERLAPPING_ GetHeaders (Headers '[] a) where
|
||||
getHeaders _ = []
|
||||
instance GetHeadersFromHList '[] where
|
||||
getHeadersFromHList _ = []
|
||||
|
||||
instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v )
|
||||
=> GetHeaders (Headers (Header h v ': rest) a) where
|
||||
getHeaders hs = getHeaders $ getHeadersHList hs
|
||||
instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs)
|
||||
=> GetHeadersFromHList (Header h x ': xs)
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
|
@ -25,26 +26,28 @@ import Data.Typeable
|
|||
(Typeable)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import GHC.TypeLits
|
||||
(Nat)
|
||||
import Network.HTTP.Types.Method
|
||||
(StdMethod (..))
|
||||
import Text.Read
|
||||
(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.
|
||||
data Stream (method :: k1) (framing :: *) (contentType :: *) (a :: *)
|
||||
-- | 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) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
|
||||
deriving (Typeable, Generic)
|
||||
|
||||
type StreamGet = Stream 'GET
|
||||
type StreamPost = Stream 'POST
|
||||
type StreamGet = Stream 'GET 200
|
||||
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).
|
||||
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.
|
||||
class ToStreamGenerator f a where
|
||||
toStreamGenerator :: f a -> StreamGenerator a
|
||||
class ToStreamGenerator a b | a -> b where
|
||||
toStreamGenerator :: a -> StreamGenerator b
|
||||
|
||||
instance ToStreamGenerator StreamGenerator a
|
||||
instance ToStreamGenerator (StreamGenerator a) a
|
||||
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.
|
||||
|
|
@ -80,6 +83,18 @@ data ByteStringParser a = ByteStringParser {
|
|||
class FramingUnrender strategy a where
|
||||
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.
|
||||
-- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON).
|
||||
|
|
|
|||
|
|
@ -19,8 +19,6 @@
|
|||
-- >>> import Servant.Utils.Links
|
||||
-- >>> import Data.Proxy
|
||||
-- >>>
|
||||
-- >>>
|
||||
-- >>>
|
||||
-- >>> type Hello = "hello" :> Get '[JSON] Int
|
||||
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
|
||||
-- >>> type API = Hello :<|> Bye
|
||||
|
|
@ -63,10 +61,24 @@
|
|||
-- >>> :set -XConstraintKinds
|
||||
-- >>> :{
|
||||
-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
|
||||
-- >>> => Proxy endpoint -> MkLink endpoint
|
||||
-- >>> => Proxy endpoint -> MkLink endpoint Link
|
||||
-- >>> 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
|
||||
-- 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.
|
||||
safeLink
|
||||
, safeLink'
|
||||
, allLinks
|
||||
, allLinks'
|
||||
, URI(..)
|
||||
-- * Adding custom types
|
||||
, HasLink(..)
|
||||
|
|
@ -276,8 +290,18 @@ safeLink
|
|||
:: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
|
||||
=> 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
|
||||
safeLink _ endpoint = toLink endpoint (Link mempty mempty)
|
||||
-> MkLink endpoint Link
|
||||
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.
|
||||
--
|
||||
|
|
@ -293,37 +317,47 @@ safeLink _ endpoint = toLink endpoint (Link mempty mempty)
|
|||
--
|
||||
-- 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))
|
||||
-- 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)) Link :: *
|
||||
-- = Char -> (Int -> Link) :<|> (Double -> Link)
|
||||
--
|
||||
allLinks
|
||||
:: forall api. HasLink api
|
||||
=> Proxy api
|
||||
-> MkLink api
|
||||
allLinks api = toLink api (Link mempty mempty)
|
||||
-> MkLink api Link
|
||||
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.
|
||||
class HasLink endpoint where
|
||||
type MkLink endpoint
|
||||
toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
type MkLink endpoint (a :: *)
|
||||
toLink
|
||||
:: (Link -> a)
|
||||
-> Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
-> Link
|
||||
-> MkLink endpoint
|
||||
-> MkLink endpoint a
|
||||
|
||||
-- Naked symbol instance
|
||||
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
|
||||
type MkLink (sym :> sub) = MkLink sub
|
||||
toLink _ =
|
||||
toLink (Proxy :: Proxy sub) . addSegment (escaped seg)
|
||||
type MkLink (sym :> sub) a = MkLink sub a
|
||||
toLink toA _ =
|
||||
toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
|
||||
where
|
||||
seg = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- QueryParam instances
|
||||
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
|
||||
=> HasLink (QueryParam' mods sym v :> sub) where
|
||||
type MkLink (QueryParam' mods sym v :> sub) = If (FoldRequired mods) v (Maybe v) -> MkLink sub
|
||||
toLink _ l mv =
|
||||
toLink (Proxy :: Proxy sub) $
|
||||
=> HasLink (QueryParam' mods sym v :> sub)
|
||||
where
|
||||
type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
|
||||
toLink toA _ l mv =
|
||||
toLink toA (Proxy :: Proxy sub) $
|
||||
case sbool :: SBool (FoldRequired mods) of
|
||||
STrue -> (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)
|
||||
|
||||
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (QueryParams sym v :> sub) where
|
||||
type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub
|
||||
toLink _ l =
|
||||
toLink (Proxy :: Proxy sub) .
|
||||
=> HasLink (QueryParams sym v :> sub)
|
||||
where
|
||||
type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
|
||||
toLink toA _ l =
|
||||
toLink toA (Proxy :: Proxy sub) .
|
||||
foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
|
||||
where
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
instance (KnownSymbol sym, HasLink sub)
|
||||
=> HasLink (QueryFlag sym :> sub) where
|
||||
type MkLink (QueryFlag sym :> sub) = Bool -> MkLink sub
|
||||
toLink _ l False =
|
||||
toLink (Proxy :: Proxy sub) l
|
||||
toLink _ l True =
|
||||
toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
|
||||
=> HasLink (QueryFlag sym :> sub)
|
||||
where
|
||||
type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
|
||||
toLink toA _ l False =
|
||||
toLink toA (Proxy :: Proxy sub) l
|
||||
toLink toA _ l True =
|
||||
toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
|
||||
where
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- :<|> instance - Generate all links at once
|
||||
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
|
||||
type MkLink (a :<|> b) = MkLink a :<|> MkLink b
|
||||
toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l
|
||||
type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
|
||||
toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
|
||||
|
||||
-- Misc instances
|
||||
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
|
||||
type MkLink (ReqBody' mods ct a :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance (ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (Capture' mods sym v :> sub) where
|
||||
type MkLink (Capture' mods sym v :> sub) = v -> MkLink sub
|
||||
toLink _ l v =
|
||||
toLink (Proxy :: Proxy sub) $
|
||||
=> HasLink (Capture' mods sym v :> sub)
|
||||
where
|
||||
type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
|
||||
toLink toA _ l v =
|
||||
toLink toA (Proxy :: Proxy sub) $
|
||||
addSegment (escaped . Text.unpack $ toUrlPiece v) l
|
||||
|
||||
instance (ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (CaptureAll sym v :> sub) where
|
||||
type MkLink (CaptureAll sym v :> sub) = [v] -> MkLink sub
|
||||
toLink _ l vs =
|
||||
toLink (Proxy :: Proxy sub) $
|
||||
=> HasLink (CaptureAll sym v :> sub)
|
||||
where
|
||||
type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
|
||||
toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
|
||||
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
|
||||
|
||||
instance HasLink sub => HasLink (Header' mods sym a :> sub) where
|
||||
type MkLink (Header' mods sym a :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
|
||||
type MkLink (Header' mods sym a :> sub) r = MkLink sub r
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Vault :> sub) where
|
||||
type MkLink (Vault :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (Vault :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Description s :> sub) where
|
||||
type MkLink (Description s :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (Description s :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Summary s :> sub) where
|
||||
type MkLink (Summary s :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (Summary s :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (HttpVersion :> sub) where
|
||||
type MkLink (HttpVersion:> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (HttpVersion:> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (IsSecure :> sub) where
|
||||
type MkLink (IsSecure :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (IsSecure :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (WithNamedContext name context sub) where
|
||||
type MkLink (WithNamedContext name context sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (WithNamedContext name context sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (RemoteHost :> sub) where
|
||||
type MkLink (RemoteHost :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (RemoteHost :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
|
||||
type MkLink (BasicAuth realm a :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink EmptyAPI where
|
||||
type MkLink EmptyAPI = EmptyAPI
|
||||
toLink _ _ = EmptyAPI
|
||||
type MkLink EmptyAPI a = EmptyAPI
|
||||
toLink _ _ _ = EmptyAPI
|
||||
|
||||
-- Verb (terminal) instances
|
||||
instance HasLink (Verb m s ct a) where
|
||||
type MkLink (Verb m s ct a) = Link
|
||||
toLink _ = id
|
||||
type MkLink (Verb m s ct a) r = r
|
||||
toLink toA _ = toA
|
||||
|
||||
instance HasLink Raw where
|
||||
type MkLink Raw = Link
|
||||
toLink _ = id
|
||||
type MkLink Raw a = a
|
||||
toLink toA _ = toA
|
||||
|
||||
instance HasLink (Stream m fr ct a) where
|
||||
type MkLink (Stream m fr ct a) = Link
|
||||
toLink _ = id
|
||||
type MkLink (Stream m fr ct a) r = r
|
||||
toLink toA _ = toA
|
||||
|
||||
-- AuthProtext instances
|
||||
instance HasLink sub => HasLink (AuthProtect tag :> sub) where
|
||||
type MkLink (AuthProtect tag :> sub) = MkLink sub
|
||||
toLink _ = toLink (Proxy :: Proxy sub)
|
||||
type MkLink (AuthProtect tag :> sub) a = MkLink sub a
|
||||
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
|
||||
-- >>> import Servant.API
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ type LinkableApi =
|
|||
|
||||
|
||||
apiLink :: (IsElem endpoint TestApi, HasLink endpoint)
|
||||
=> Proxy endpoint -> MkLink endpoint
|
||||
=> Proxy endpoint -> MkLink endpoint Link
|
||||
apiLink = safeLink (Proxy :: Proxy TestApi)
|
||||
|
||||
-- | Convert a link to a URI and ensure that this maps to the given string
|
||||
|
|
|
|||
Loading…
Reference in a new issue