Merge master and fix conflicts
This commit is contained in:
Erik Aker
commit
7d2997098a
70 changed files with 612 additions and 1106 deletions
107
.travis.yml
107
.travis.yml
|
|
@ -4,10 +4,12 @@
|
|||
#
|
||||
# For more information, see https://github.com/haskell-CI/haskell-ci
|
||||
#
|
||||
# version: 0.5.20190916
|
||||
# version: 0.9.20200110
|
||||
#
|
||||
version: ~> 1.0
|
||||
language: c
|
||||
dist: xenial
|
||||
os: linux
|
||||
dist: bionic
|
||||
git:
|
||||
# whether to recursively clone submodules
|
||||
submodules: false
|
||||
|
|
@ -20,6 +22,7 @@ cache:
|
|||
directories:
|
||||
- $HOME/.cabal/packages
|
||||
- $HOME/.cabal/store
|
||||
- $HOME/.hlint
|
||||
before_cache:
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
|
||||
# remove files that are regenerated by 'cabal update'
|
||||
|
|
@ -29,20 +32,26 @@ before_cache:
|
|||
- rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
|
||||
- rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
|
||||
- rm -rfv $CABALHOME/packages/head.hackage
|
||||
matrix:
|
||||
jobs:
|
||||
include:
|
||||
- compiler: ghcjs-8.4
|
||||
addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}
|
||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"},{"sourceline":"deb http://ppa.launchpad.net/hvr/ghcjs/ubuntu bionic main"},{"sourceline":"deb https://deb.nodesource.com/node_10.x bionic main","key_url":"https://deb.nodesource.com/gpgkey/nodesource.gpg.key"}],"packages":["ghcjs-8.4","cabal-install-3.0","ghc-8.4.4","nodejs"]}}
|
||||
os: linux
|
||||
- compiler: ghc-8.8.1
|
||||
addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
|
||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
|
||||
os: linux
|
||||
- compiler: ghc-8.6.5
|
||||
addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
|
||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}}
|
||||
os: linux
|
||||
- compiler: ghc-8.4.4
|
||||
addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
|
||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}}
|
||||
os: linux
|
||||
- compiler: ghc-8.2.2
|
||||
addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
|
||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}}
|
||||
os: linux
|
||||
- compiler: ghc-8.0.2
|
||||
addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
|
||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}}
|
||||
os: linux
|
||||
before_install:
|
||||
- |
|
||||
if echo $CC | grep -q ghcjs; then
|
||||
|
|
@ -50,21 +59,11 @@ before_install:
|
|||
else
|
||||
GHCJS=false;
|
||||
fi
|
||||
- |
|
||||
if [ "$TRAVIS_OS_NAME" = "linux" ]; then
|
||||
if $GHCJS ; then sudo add-apt-repository -y ppa:hvr/ghcjs ; fi;
|
||||
if $GHCJS ; then curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add - ; fi;
|
||||
if $GHCJS ; then sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main' ; fi;
|
||||
if $GHCJS ; then sudo apt-get update ; fi;
|
||||
sudo apt-get install $CC;
|
||||
if $GHCJS ; then sudo apt-get install -y nodejs cabal-install-3.0 ; fi;
|
||||
fi
|
||||
- HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
|
||||
- WITHCOMPILER="-w $HC"
|
||||
- if $GHCJS ; then HC=${HC}js ; fi
|
||||
- if $GHCJS ; then WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" ; fi
|
||||
- HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
|
||||
- if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi
|
||||
- if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi
|
||||
- HCPKG="$HC-pkg"
|
||||
- unset CC
|
||||
|
|
@ -74,26 +73,8 @@ before_install:
|
|||
- TOP=$(pwd)
|
||||
- "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
|
||||
- echo $HCNUMVER
|
||||
- CABAL="$CABAL -vnormal+nowrap+markoutput"
|
||||
- CABAL="$CABAL -vnormal+nowrap"
|
||||
- set -o pipefail
|
||||
- |
|
||||
echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
|
||||
echo 'BEGIN { state = "output"; }' >> .colorful.awk
|
||||
echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
|
||||
echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
|
||||
echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
|
||||
echo ' if (state == "cabal") {' >> .colorful.awk
|
||||
echo ' print blue($0)' >> .colorful.awk
|
||||
echo ' } else {' >> .colorful.awk
|
||||
echo ' print $0' >> .colorful.awk
|
||||
echo ' }' >> .colorful.awk
|
||||
echo '}' >> .colorful.awk
|
||||
- cat .colorful.awk
|
||||
- |
|
||||
color_cabal_output () {
|
||||
awk -f $TOP/.colorful.awk
|
||||
}
|
||||
- echo text | color_cabal_output
|
||||
install:
|
||||
- ${CABAL} --version
|
||||
- echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
|
||||
|
|
@ -119,6 +100,14 @@ install:
|
|||
echo " prefix: $CABALHOME" >> $CABALHOME/config
|
||||
echo "repository hackage.haskell.org" >> $CABALHOME/config
|
||||
echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
|
||||
echo " secure: True" >> $CABALHOME/config
|
||||
echo " key-threshold: 3" >> $CABALHOME/config
|
||||
echo " root-keys:" >> $CABALHOME/config
|
||||
echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config
|
||||
echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config
|
||||
echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config
|
||||
echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config
|
||||
echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config
|
||||
- GHCJOBS=-j2
|
||||
- |
|
||||
echo "program-default-options" >> $CABALHOME/config
|
||||
|
|
@ -126,8 +115,9 @@ install:
|
|||
- cat $CABALHOME/config
|
||||
- rm -fv cabal.project cabal.project.local cabal.project.freeze
|
||||
- travis_retry ${CABAL} v2-update -v
|
||||
- if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe' | color_cabal_output) ; fi
|
||||
- if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover | color_cabal_output) ; fi
|
||||
- if ! $GHCJS ; then (cd /tmp && ${CABAL} v2-install $WITHCOMPILER -j2 doctest --constraint='doctest ==0.16.2.*') ; fi
|
||||
- if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe') ; fi
|
||||
- if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover) ; fi
|
||||
# Generate cabal.project
|
||||
- rm -rf cabal.project cabal.project.local cabal.project.freeze
|
||||
- touch cabal.project
|
||||
|
|
@ -143,7 +133,6 @@ install:
|
|||
if ! $GHCJS ; then echo "packages: servant-machines" >> cabal.project ; fi
|
||||
if ! $GHCJS ; then echo "packages: servant-conduit" >> cabal.project ; fi
|
||||
if ! $GHCJS ; then echo "packages: servant-pipes" >> cabal.project ; fi
|
||||
if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then echo "packages: servant-jsaddle" >> cabal.project ; fi
|
||||
if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi
|
||||
if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi
|
||||
if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi
|
||||
|
|
@ -159,6 +148,7 @@ install:
|
|||
echo "constraints: foundation >=0.0.14" >> cabal.project
|
||||
echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
|
||||
echo "constraints: sqlite-simple < 0" >> cabal.project
|
||||
echo "constraints: base-compat ^>=0.11" >> cabal.project
|
||||
echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project
|
||||
echo "allow-newer: vault-0.3.1.2:hashable" >> cabal.project
|
||||
echo "allow-newer: psqueues-0.2.7.1:hashable" >> cabal.project
|
||||
|
|
@ -168,7 +158,7 @@ install:
|
|||
echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project
|
||||
echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project
|
||||
echo "optimization: False" >> cabal.project
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
- if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
|
||||
|
|
@ -182,7 +172,6 @@ install:
|
|||
- if [ -f "servant-machines/configure.ac" ]; then (cd "servant-machines" && autoreconf -i); fi
|
||||
- if [ -f "servant-conduit/configure.ac" ]; then (cd "servant-conduit" && autoreconf -i); fi
|
||||
- if [ -f "servant-pipes/configure.ac" ]; then (cd "servant-pipes" && autoreconf -i); fi
|
||||
- if [ -f "servant-jsaddle/configure.ac" ]; then (cd "servant-jsaddle" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then (cd "doc/cookbook/basic-auth" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then (cd "doc/cookbook/curl-mock" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then (cd "doc/cookbook/basic-streaming" && autoreconf -i); fi
|
||||
|
|
@ -194,14 +183,14 @@ install:
|
|||
- if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi
|
||||
- if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi
|
||||
- ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
|
||||
- ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
|
||||
- "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
|
||||
- rm cabal.project.freeze
|
||||
script:
|
||||
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
|
||||
# Packaging...
|
||||
- echo 'Packaging...' && echo -en 'travis_fold:start:sdist\\r'
|
||||
- ${CABAL} v2-sdist all | color_cabal_output
|
||||
- ${CABAL} v2-sdist all
|
||||
- echo -en 'travis_fold:end:sdist\\r'
|
||||
# Unpacking...
|
||||
- echo 'Unpacking...' && echo -en 'travis_fold:start:unpack\\r'
|
||||
|
|
@ -220,7 +209,6 @@ script:
|
|||
- PKGDIR_servant_machines="$(find . -maxdepth 1 -type d -regex '.*/servant-machines-[0-9.]*')"
|
||||
- PKGDIR_servant_conduit="$(find . -maxdepth 1 -type d -regex '.*/servant-conduit-[0-9.]*')"
|
||||
- PKGDIR_servant_pipes="$(find . -maxdepth 1 -type d -regex '.*/servant-pipes-[0-9.]*')"
|
||||
- PKGDIR_servant_jsaddle="$(find . -maxdepth 1 -type d -regex '.*/servant-jsaddle-[0-9.]*')"
|
||||
- PKGDIR_cookbook_basic_auth="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-auth-[0-9.]*')"
|
||||
- PKGDIR_cookbook_curl_mock="$(find . -maxdepth 1 -type d -regex '.*/cookbook-curl-mock-[0-9.]*')"
|
||||
- PKGDIR_cookbook_basic_streaming="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-streaming-[0-9.]*')"
|
||||
|
|
@ -247,7 +235,6 @@ script:
|
|||
if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_machines}" >> cabal.project ; fi
|
||||
if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_conduit}" >> cabal.project ; fi
|
||||
if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi
|
||||
if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then echo "packages: ${PKGDIR_servant_jsaddle}" >> cabal.project ; fi
|
||||
if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi
|
||||
if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi
|
||||
if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi
|
||||
|
|
@ -263,6 +250,7 @@ script:
|
|||
echo "constraints: foundation >=0.0.14" >> cabal.project
|
||||
echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project
|
||||
echo "constraints: sqlite-simple < 0" >> cabal.project
|
||||
echo "constraints: base-compat ^>=0.11" >> cabal.project
|
||||
echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project
|
||||
echo "allow-newer: vault-0.3.1.2:hashable" >> cabal.project
|
||||
echo "allow-newer: psqueues-0.2.7.1:hashable" >> cabal.project
|
||||
|
|
@ -272,7 +260,7 @@ script:
|
|||
echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project
|
||||
echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project
|
||||
echo "optimization: False" >> cabal.project
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
- |
|
||||
|
|
@ -289,7 +277,6 @@ script:
|
|||
servant-machines) echo ${PKGDIR_servant_machines} ;;
|
||||
servant-conduit) echo ${PKGDIR_servant_conduit} ;;
|
||||
servant-pipes) echo ${PKGDIR_servant_pipes} ;;
|
||||
servant-jsaddle) echo ${PKGDIR_servant_jsaddle} ;;
|
||||
cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;;
|
||||
cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;;
|
||||
cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;;
|
||||
|
|
@ -307,15 +294,29 @@ script:
|
|||
# Building with tests and benchmarks...
|
||||
- echo 'Building with tests and benchmarks...' && echo -en 'travis_fold:start:build-everything\\r'
|
||||
# build & run tests, build benchmarks
|
||||
- ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
|
||||
- ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
|
||||
- echo -en 'travis_fold:end:build-everything\\r'
|
||||
# Testing...
|
||||
- if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
|
||||
- if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all ; fi
|
||||
- if $GHCJS ; then cabal-plan list-bins '*:test:*' | while read -r line; do testpkg=$(echo "$line" | perl -pe 's/:.*//'); testexe=$(echo "$line" | awk '{ print $2 }'); echo "testing $textexe in package $textpkg"; (cd "$(pkgdir $testpkg)" && nodejs "$testexe".jsexe/all.js); done ; fi
|
||||
# Doctest...
|
||||
- echo 'Doctest...' && echo -en 'travis_fold:start:doctest\\r'
|
||||
- perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_client} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_client_core} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_http_streams} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_docs} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_foreign} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_server} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_machines} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_conduit} && doctest src) ; fi
|
||||
- if ! $GHCJS ; then (cd ${PKGDIR_servant_pipes} && doctest src) ; fi
|
||||
- echo -en 'travis_fold:end:doctest\\r'
|
||||
# haddock...
|
||||
- echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r'
|
||||
- if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi
|
||||
- if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi
|
||||
- echo -en 'travis_fold:end:haddock\\r'
|
||||
|
||||
# REGENDATA ["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]
|
||||
# REGENDATA ("0.9.20200110",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"])
|
||||
# EOF
|
||||
|
|
|
|||
|
|
@ -35,7 +35,34 @@ Some things we like:
|
|||
Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs`
|
||||
files in the repository provide a good baseline for consistency.
|
||||
|
||||
**Important**: please do not modify the changelog files nor the versions of the servant packages you are sending patches for. We take care of this before every release and do it uniformly for all the servant packages, so there's no need to worry about this for your pull requests.
|
||||
**Important**: please do not modify the versions of the servant packages you are sending patches for.
|
||||
|
||||
## Changelog entries
|
||||
|
||||
We experiment with using [changelog-d tool](https://github.com/phadej/changelog-d) to assemble changelogs.
|
||||
You are not required to install it.
|
||||
|
||||
In each PR please add a file to `changelog.d` directory named after issue you are solving or the pull request itself (in a separate commit after you know the pull request number). For example
|
||||
|
||||
```cabal
|
||||
synopsis: One sentence summary of the change.
|
||||
prs: #1219
|
||||
issues: #1028
|
||||
|
||||
description: {
|
||||
|
||||
A longer description. Small changes don't need this.
|
||||
Bigger ones definitely do, for example we try to include migration hints
|
||||
for breaking changes.
|
||||
|
||||
However if you don't know what to write, that's ok too.
|
||||
|
||||
By the way, the braces around are omitted when the file is parsed.
|
||||
They can be used so the field doesn't need to be indented, which is handy
|
||||
for prose.
|
||||
|
||||
}
|
||||
```
|
||||
|
||||
## PR process
|
||||
|
||||
|
|
|
|||
10
Makefile
10
Makefile
|
|
@ -20,3 +20,13 @@ build-ghcjs :
|
|||
|
||||
packdeps :
|
||||
packdeps */*.cabal
|
||||
|
||||
doctest : doctest-servant doctest-servant-server
|
||||
perl -i -e 'while (<ARGV>) { print unless /package-id\s+base-compat-\d+(\.\d+)*/; }' .ghc.environment.*
|
||||
|
||||
doctest-servant :
|
||||
(cd servant && doctest src)
|
||||
(cd servant && doctest test/Servant/LinksSpec.hs)
|
||||
|
||||
doctest-servant-server :
|
||||
(cd servant-server && doctest src)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,12 @@
|
|||
distribution: bionic
|
||||
folds: all-but-test
|
||||
branches: master
|
||||
jobs-selection: any
|
||||
google-chrome: True
|
||||
ghcjs-tests: True
|
||||
doctest: True
|
||||
doctest-filter-packages: base-compat-batteries
|
||||
doctest-skip: tutorial
|
||||
|
||||
-- https://github.com/haskell/cabal/issues/6176
|
||||
ghcjs-tools: hspec-discover
|
||||
|
|
|
|||
|
|
@ -15,8 +15,8 @@ packages:
|
|||
servant-pipes/
|
||||
|
||||
-- servant GHCJS
|
||||
packages:
|
||||
servant-jsaddle/
|
||||
-- packages:
|
||||
-- servant-jsaddle/
|
||||
|
||||
-- Cookbooks
|
||||
packages:
|
||||
|
|
@ -38,8 +38,6 @@ packages:
|
|||
doc/cookbook/using-free-client
|
||||
-- doc/cookbook/open-id-connect
|
||||
|
||||
|
||||
|
||||
tests: True
|
||||
optimization: False
|
||||
-- reorder-goals: True
|
||||
|
|
@ -62,3 +60,8 @@ allow-newer: openssl-streams-1.2.2.0:network
|
|||
-- MonadFail
|
||||
-- https://github.com/nurpax/sqlite-simple/issues/74
|
||||
constraints: sqlite-simple < 0
|
||||
|
||||
constraints: base-compat ^>=0.11
|
||||
|
||||
-- needed for doctests
|
||||
write-ghc-environment-files: always
|
||||
|
|
|
|||
2
changelog.d/config
Normal file
2
changelog.d/config
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
organization: haskell-servant
|
||||
repository: servant
|
||||
18
changelog.d/issue1028
Normal file
18
changelog.d/issue1028
Normal file
|
|
@ -0,0 +1,18 @@
|
|||
synopsis: Add NoContentVerb
|
||||
prs: #1228 #1219
|
||||
issues: #1028
|
||||
significance: significant
|
||||
|
||||
description: {
|
||||
|
||||
The `NoContent` API endpoints should now use `NoContentVerb` combinator.
|
||||
The API type changes are usually of the kind
|
||||
|
||||
```diff
|
||||
- :<|> PostNoContent '[JSON] NoContent
|
||||
+ :<|> PostNoContent
|
||||
```
|
||||
|
||||
i.e. one doesn't need to specify the content-type anymore. There is no content.
|
||||
|
||||
}
|
||||
12
changelog.d/issue1200
Normal file
12
changelog.d/issue1200
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
synopsis: Fix Verb with headers checking content type differently
|
||||
packages: servant-client-core servant-client
|
||||
prs: #1204
|
||||
issues: #1200
|
||||
packages: servant-client servant-client-core servant-http-streams
|
||||
|
||||
description: {
|
||||
|
||||
For `Verb`s with response `Headers`, the implementation didn't check
|
||||
for the content-type of the response. Now it does.
|
||||
|
||||
}
|
||||
16
changelog.d/issue1240
Normal file
16
changelog.d/issue1240
Normal file
|
|
@ -0,0 +1,16 @@
|
|||
synopsis: Merge documentation from duplicate routes
|
||||
packages: servant-docs
|
||||
prs: #1241
|
||||
issues: #1240
|
||||
|
||||
description: {
|
||||
|
||||
Servant supports defining the same route multiple times with different
|
||||
content-types and result-types, but servant-docs was only documenting
|
||||
the first of copy of such duplicated routes. It now combines the
|
||||
documentation from all the copies.
|
||||
|
||||
Unfortunately, it is not yet possible for the documentation to specify
|
||||
multiple status codes.
|
||||
|
||||
}
|
||||
3
changelog.d/jsaddle
Normal file
3
changelog.d/jsaddle
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
synopsis: Progress on servant-jsaddle
|
||||
packages: servant-jsaddle
|
||||
prs: #1216
|
||||
17
changelog.d/pr1156
Normal file
17
changelog.d/pr1156
Normal file
|
|
@ -0,0 +1,17 @@
|
|||
synopsis: `Capture` can be `Lenient`
|
||||
issues: #1155
|
||||
prs: #1156
|
||||
significance: significant
|
||||
description: {
|
||||
|
||||
You can specify a lenient capture as
|
||||
|
||||
```haskell
|
||||
:<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET
|
||||
```
|
||||
|
||||
which will make the capture always succeed. Handlers will be of the
|
||||
type `Either String CapturedType`, where `Left err` represents
|
||||
the possible parse failure.
|
||||
|
||||
}
|
||||
7
changelog.d/pr1190
Normal file
7
changelog.d/pr1190
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
synopsis: Add sponsorship button
|
||||
prs: #1190
|
||||
description: {
|
||||
|
||||
[Well-Typed](https://www.well-typed.com/)
|
||||
|
||||
}
|
||||
3
changelog.d/pr1194
Normal file
3
changelog.d/pr1194
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
synopsis: Prevent race-conditions in testing
|
||||
packages: servant-docs
|
||||
prs: #1194
|
||||
4
changelog.d/pr1197
Normal file
4
changelog.d/pr1197
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
synopsis: `HasClient` instance for `Stream` with `Headers`
|
||||
packages: servant-client servant-client servant-http-streams
|
||||
prs: #1197
|
||||
issues: #1170
|
||||
3
changelog.d/pr1201
Normal file
3
changelog.d/pr1201
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
synopsis: Remove unused extensions from cabal file
|
||||
packages: servant
|
||||
prs: #1201
|
||||
12
changelog.d/pr1213
Normal file
12
changelog.d/pr1213
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
synopsis: Added a function to create Client.Request in ClientEnv
|
||||
packages: servant-client
|
||||
significance: significant
|
||||
prs: #1213 #1255
|
||||
description: {
|
||||
|
||||
The new member `makeClientRequest` of `ClientEnv` is used to create
|
||||
`http-client` `Request` from `servant-client-core` `Request`.
|
||||
This functionality can be used for example to set
|
||||
dynamic timeouts for each request.
|
||||
|
||||
}
|
||||
3
changelog.d/pr1238
Normal file
3
changelog.d/pr1238
Normal file
|
|
@ -0,0 +1,3 @@
|
|||
synopsis: Redact the authorization header in Show and exceptions
|
||||
packages: servant-client
|
||||
prs: #1238
|
||||
15
changelog.d/pr1249
Normal file
15
changelog.d/pr1249
Normal file
|
|
@ -0,0 +1,15 @@
|
|||
synopsis: use queryString to parse QueryParam, QueryParams and QueryFlag
|
||||
packages: servant-server
|
||||
prs: #1249 #1262
|
||||
significance: significant
|
||||
description: {
|
||||
|
||||
Some APIs need query parameters rewriting, e.g. in order to support
|
||||
for multiple casing (camel, snake, etc) or something to that effect.
|
||||
|
||||
This could be easily achieved by using WAI Middleware and modyfing
|
||||
request's `Query`. But QueryParam, QueryParams and QueryFlag use
|
||||
`rawQueryString`. By using `queryString` rather then `rawQueryString`
|
||||
we can enable such rewritings.
|
||||
|
||||
}
|
||||
11
changelog.d/pr1263
Normal file
11
changelog.d/pr1263
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
synopsis: Make packages `build-type: Simple`
|
||||
packages: servant servant-server
|
||||
prs: #1263
|
||||
significance: significant
|
||||
description: {
|
||||
|
||||
We used `build-type: Custom`, but it's problematic e.g.
|
||||
for cross-compiling. The benefit is small, as the doctests
|
||||
can be run other ways too (though not so conviniently).
|
||||
|
||||
}
|
||||
8
changelog.d/z-changelog-d
Normal file
8
changelog.d/z-changelog-d
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
synopsis: Try changelog-d for changelog management
|
||||
prs: #1230
|
||||
|
||||
description: {
|
||||
|
||||
Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details
|
||||
|
||||
}
|
||||
19
changelog.d/z-ci-tweaks
Normal file
19
changelog.d/z-ci-tweaks
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
synopsis: CI and testing tweaks.
|
||||
prs:
|
||||
#1154
|
||||
#1157
|
||||
#1182
|
||||
#1214
|
||||
#1229
|
||||
#1233
|
||||
#1242
|
||||
#1247
|
||||
#1250
|
||||
#1258
|
||||
|
||||
description: {
|
||||
|
||||
We are experiencing some bitrotting of cookbook recipe dependencies,
|
||||
therefore some of them aren't build as part of our CI anymore.
|
||||
|
||||
}
|
||||
9
changelog.d/z-cookbook
Normal file
9
changelog.d/z-cookbook
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
synopsis: New cookbook recipes
|
||||
prs: #1171 #1088 #1198
|
||||
|
||||
description: {
|
||||
|
||||
- [OIDC Recipe](#TODO)
|
||||
- [MySQL Recipe](#TODO)
|
||||
|
||||
}
|
||||
9
changelog.d/z-dependency-upgrades
Normal file
9
changelog.d/z-dependency-upgrades
Normal file
|
|
@ -0,0 +1,9 @@
|
|||
synopsis: Dependency upgrades
|
||||
prs:
|
||||
#1173
|
||||
#1181
|
||||
#1183
|
||||
#1188
|
||||
#1224
|
||||
#1245
|
||||
#1257
|
||||
8
changelog.d/z-documentation-updates
Normal file
8
changelog.d/z-documentation-updates
Normal file
|
|
@ -0,0 +1,8 @@
|
|||
synopsis: Documentation updates
|
||||
prs:
|
||||
#1162
|
||||
#1174
|
||||
#1175
|
||||
#1234
|
||||
#1244
|
||||
#1247
|
||||
|
|
@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request`
|
|||
to http-client's `Request`, and we can inspect it:
|
||||
|
||||
```haskell
|
||||
let req' = I.requestToClientRequest burl req
|
||||
let req' = I.defaultMakeClientRequest burl req
|
||||
putStrLn $ "Making request: " ++ show req'
|
||||
```
|
||||
|
||||
|
|
|
|||
|
|
@ -318,7 +318,7 @@ genAuthAPI = Proxy
|
|||
|
||||
Now we need to bring everything together for the server. We have the
|
||||
`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these
|
||||
together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html)
|
||||
together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/8.8.1/docs/html/users_guide/glasgow_exts.html#type-families)
|
||||
instance that tells the `HasServer` instance that our `Context` will supply a
|
||||
`Account` (via `AuthHandler Request Account`) and that downstream combinators will
|
||||
have access to this `Account` value (or an error will be thrown if authentication
|
||||
|
|
@ -368,10 +368,10 @@ genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuth
|
|||
$ curl -XGET localhost:8080/private
|
||||
Missing auth header
|
||||
|
||||
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
|
||||
$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=key3"
|
||||
[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
|
||||
|
||||
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
|
||||
$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=bad-key"
|
||||
Invalid Cookie
|
||||
|
||||
$ curl -XGET localhost:8080/public
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
# Querying an API
|
||||
|
||||
While defining handlers that [serve an API](Server.lhs) has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. That said, we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate the client-side functions.
|
||||
While defining handlers that [serve an API](Server.html) has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. That said, we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate the client-side functions.
|
||||
|
||||
**servant** however has a way to inspect APIs, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurrence of `Capture`, `ReqBody`, `QueryParam`
|
||||
and friends (see [the tutorial introduction](ApiType.lhs) for an overview). By *derive*, we mean that there's no code generation involved - the functions are defined just by the structure of the API type.
|
||||
and friends (see [the tutorial introduction](ApiType.html) for an overview). By *derive*, we mean that there's no code generation involved - the functions are defined just by the structure of the API type.
|
||||
|
||||
The source for this tutorial section is a literate Haskell file, so first we need to have some language extensions and imports:
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +1,11 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
module Main where
|
||||
|
||||
import qualified JavascriptSpec
|
||||
|
||||
import Test.Hspec (Spec, hspec, describe)
|
||||
|
||||
main :: IO ()
|
||||
main = hspec spec
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Javascript" JavascriptSpec.spec
|
||||
|
|
|
|||
|
|
@ -66,7 +66,7 @@ library
|
|||
blaze-html >= 0.9.0.1 && < 0.10
|
||||
, blaze-markup >= 0.8.0.0 && < 0.9
|
||||
, cookie >= 0.4.3 && < 0.5
|
||||
, js-jquery >= 3.2.1 && < 3.3
|
||||
, js-jquery >= 3.3.1 && < 3.4
|
||||
, lucid >= 2.9.11 && < 2.10
|
||||
, random >= 1.1 && < 1.2
|
||||
, servant-js >= 0.9 && < 0.10
|
||||
|
|
@ -83,8 +83,6 @@ test-suite spec
|
|||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
other-modules: JavascriptSpec
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover
|
||||
build-depends: base
|
||||
, tutorial
|
||||
, hspec
|
||||
|
|
|
|||
|
|
@ -97,6 +97,7 @@ test-suite spec
|
|||
main-is: Spec.hs
|
||||
other-modules:
|
||||
Servant.Client.Core.Internal.BaseUrlSpec
|
||||
Servant.Client.Core.RequestSpec
|
||||
|
||||
-- Dependencies inherited from the library. No need to specify bounds.
|
||||
build-depends:
|
||||
|
|
|
|||
|
|
@ -67,8 +67,32 @@ data RequestF body path = Request
|
|||
, requestHeaders :: Seq.Seq Header
|
||||
, requestHttpVersion :: HttpVersion
|
||||
, requestMethod :: Method
|
||||
} deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable)
|
||||
} deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable)
|
||||
|
||||
instance (Show a, Show b) =>
|
||||
Show (Servant.Client.Core.Request.RequestF a b) where
|
||||
showsPrec p req
|
||||
= showParen
|
||||
(p >= 11)
|
||||
( showString "Request {requestPath = "
|
||||
. showsPrec 0 (requestPath req)
|
||||
. showString ", requestQueryString = "
|
||||
. showsPrec 0 (requestQueryString req)
|
||||
. showString ", requestBody = "
|
||||
. showsPrec 0 (requestBody req)
|
||||
. showString ", requestAccept = "
|
||||
. showsPrec 0 (requestAccept req)
|
||||
. showString ", requestHeaders = "
|
||||
. showsPrec 0 (redactSensitiveHeader <$> requestHeaders req))
|
||||
. showString ", requestHttpVersion = "
|
||||
. showsPrec 0 (requestHttpVersion req)
|
||||
. showString ", requestMethod = "
|
||||
. showsPrec 0 (requestMethod req)
|
||||
. showString "}"
|
||||
where
|
||||
redactSensitiveHeader :: Header -> Header
|
||||
redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")
|
||||
redactSensitiveHeader h = h
|
||||
instance Bifunctor RequestF where bimap = bimapDefault
|
||||
instance Bifoldable RequestF where bifoldMap = bifoldMapDefault
|
||||
instance Bitraversable RequestF where
|
||||
|
|
|
|||
19
servant-client-core/test/Servant/Client/Core/RequestSpec.hs
Normal file
19
servant-client-core/test/Servant/Client/Core/RequestSpec.hs
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Servant.Client.Core.RequestSpec (spec) where
|
||||
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Control.Monad
|
||||
import Data.List (isInfixOf)
|
||||
import Servant.Client.Core.Request
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Request" $ do
|
||||
describe "show" $ do
|
||||
it "redacts the authorization header" $ do
|
||||
let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") }
|
||||
isInfixOf "secret" (show request) `shouldBe` False
|
||||
|
|
@ -1,6 +1,11 @@
|
|||
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/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.16.0.1
|
||||
--------
|
||||
|
||||
- Allow `base-compat-0.11`
|
||||
|
||||
0.16
|
||||
----
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
cabal-version: >=1.10
|
||||
name: servant-client
|
||||
version: 0.16
|
||||
version: 0.16.0.1
|
||||
|
||||
synopsis: Automatic derivation of querying functions for servant
|
||||
category: Servant, Web
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ module Servant.Client
|
|||
, runClientM
|
||||
, ClientEnv(..)
|
||||
, mkClientEnv
|
||||
, defaultMakeClientRequest
|
||||
, hoistClient
|
||||
, module Servant.Client.Core.Reexport
|
||||
) where
|
||||
|
|
|
|||
|
|
@ -16,10 +16,11 @@ import Prelude.Compat
|
|||
|
||||
import Control.Concurrent.MVar
|
||||
(modifyMVar, newMVar)
|
||||
import qualified Data.ByteString as BS
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Exception
|
||||
(SomeException (..), catch)
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Catch
|
||||
|
|
@ -27,15 +28,18 @@ import Control.Monad.Catch
|
|||
import Control.Monad.Error.Class
|
||||
(MonadError (..))
|
||||
import Control.Monad.IO.Class
|
||||
(liftIO)
|
||||
(MonadIO (..))
|
||||
import Control.Monad.Reader
|
||||
(MonadReader, ReaderT, ask, runReaderT)
|
||||
import Control.Monad.STM
|
||||
(STM, atomically)
|
||||
import Control.Monad.Trans.Control
|
||||
(MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except
|
||||
(ExceptT, runExceptT)
|
||||
import Data.Bifunctor
|
||||
(bimap)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Builder
|
||||
(toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
|
|
@ -64,20 +68,31 @@ import Network.HTTP.Types
|
|||
(hContentType, renderQuery, statusCode)
|
||||
import Servant.Client.Core
|
||||
|
||||
import qualified Servant.Types.SourceT as S
|
||||
import qualified Network.HTTP.Client as Client
|
||||
import qualified Servant.Types.SourceT as S
|
||||
|
||||
-- | The environment in which a request is run.
|
||||
-- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request.
|
||||
-- Cookies are then added to that request if a 'CookieJar' is set on the environment.
|
||||
-- Finally the request is executed with the 'manager'.
|
||||
-- The 'makeClientRequest' function can be used to modify the request to execute and set values which
|
||||
-- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount'
|
||||
data ClientEnv
|
||||
= ClientEnv
|
||||
{ manager :: Client.Manager
|
||||
, baseUrl :: BaseUrl
|
||||
, cookieJar :: Maybe (TVar Client.CookieJar)
|
||||
, makeClientRequest :: BaseUrl -> Request -> Client.Request
|
||||
-- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest'
|
||||
-- Note that:
|
||||
-- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request,
|
||||
-- If you need global modifications, you should use 'managerModifyRequest'
|
||||
-- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called.
|
||||
}
|
||||
|
||||
-- | 'ClientEnv' smart constructor.
|
||||
mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv
|
||||
mkClientEnv mgr burl = ClientEnv mgr burl Nothing
|
||||
mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest
|
||||
|
||||
-- | Generates a set of client functions for an API.
|
||||
--
|
||||
|
|
@ -148,8 +163,8 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
|
|||
|
||||
performRequest :: Request -> ClientM Response
|
||||
performRequest req = do
|
||||
ClientEnv m burl cookieJar' <- ask
|
||||
let clientRequest = requestToClientRequest burl req
|
||||
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||
let clientRequest = createClientRequest burl req
|
||||
request <- case cookieJar' of
|
||||
Nothing -> pure clientRequest
|
||||
Just cj -> liftIO $ do
|
||||
|
|
@ -158,7 +173,7 @@ performRequest req = do
|
|||
oldCookieJar <- readTVar cj
|
||||
let (newRequest, newCookieJar) =
|
||||
Client.insertCookiesIntoRequest
|
||||
(requestToClientRequest burl req)
|
||||
clientRequest
|
||||
oldCookieJar
|
||||
now
|
||||
writeTVar cj newCookieJar
|
||||
|
|
@ -211,8 +226,11 @@ clientResponseToResponse f r = Response
|
|||
, responseHttpVersion = Client.responseVersion r
|
||||
}
|
||||
|
||||
requestToClientRequest :: BaseUrl -> Request -> Client.Request
|
||||
requestToClientRequest burl r = Client.defaultRequest
|
||||
-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
|
||||
-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl'
|
||||
-- otherwise the body, headers and query string are derived from the @servant@ 'Request'
|
||||
defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request
|
||||
defaultMakeClientRequest burl r = Client.defaultRequest
|
||||
{ Client.method = requestMethod r
|
||||
, Client.host = fromString $ baseUrlHost burl
|
||||
, Client.port = baseUrlPort burl
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming (
|
|||
ClientEnv (..),
|
||||
mkClientEnv,
|
||||
clientResponseToResponse,
|
||||
requestToClientRequest,
|
||||
defaultMakeClientRequest,
|
||||
catchConnectionError,
|
||||
) where
|
||||
|
||||
|
|
@ -55,7 +55,7 @@ import Servant.Client.Core
|
|||
import Servant.Client.Internal.HttpClient
|
||||
(ClientEnv (..), catchConnectionError,
|
||||
clientResponseToResponse, mkClientEnv, mkFailureResponse,
|
||||
requestToClientRequest)
|
||||
defaultMakeClientRequest)
|
||||
import qualified Servant.Types.SourceT as S
|
||||
|
||||
|
||||
|
|
@ -139,8 +139,8 @@ runClientM cm env = withClientM cm env (evaluate . force)
|
|||
performRequest :: Request -> ClientM Response
|
||||
performRequest req = do
|
||||
-- TODO: should use Client.withResponse here too
|
||||
ClientEnv m burl cookieJar' <- ask
|
||||
let clientRequest = requestToClientRequest burl req
|
||||
ClientEnv m burl cookieJar' createClientRequest <- ask
|
||||
let clientRequest = createClientRequest burl req
|
||||
request <- case cookieJar' of
|
||||
Nothing -> pure clientRequest
|
||||
Just cj -> liftIO $ do
|
||||
|
|
@ -149,7 +149,7 @@ performRequest req = do
|
|||
oldCookieJar <- readTVar cj
|
||||
let (newRequest, newCookieJar) =
|
||||
Client.insertCookiesIntoRequest
|
||||
(requestToClientRequest burl req)
|
||||
clientRequest
|
||||
oldCookieJar
|
||||
now
|
||||
writeTVar cj newCookieJar
|
||||
|
|
@ -173,7 +173,8 @@ performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM
|
|||
performWithStreamingRequest req k = do
|
||||
m <- asks manager
|
||||
burl <- asks baseUrl
|
||||
let request = requestToClientRequest burl req
|
||||
createClientRequest <- asks makeClientRequest
|
||||
let request = createClientRequest burl req
|
||||
ClientM $ lift $ lift $ Codensity $ \k1 ->
|
||||
Client.withResponse request m $ \res -> do
|
||||
let status = Client.responseStatus res
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@ module Servant.Client.Streaming
|
|||
, runClientM
|
||||
, ClientEnv(..)
|
||||
, mkClientEnv
|
||||
, defaultMakeClientRequest
|
||||
, hoistClient
|
||||
, module Servant.Client.Core.Reexport
|
||||
) where
|
||||
|
|
|
|||
|
|
@ -93,6 +93,7 @@ type Api =
|
|||
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
|
||||
:<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool
|
||||
:<|> "rawSuccess" :> Raw
|
||||
:<|> "rawSuccessPassHeaders" :> Raw
|
||||
:<|> "rawFailure" :> Raw
|
||||
:<|> "multiple" :>
|
||||
Capture "first" String :>
|
||||
|
|
@ -118,6 +119,7 @@ getQueryParam :: Maybe String -> ClientM Person
|
|||
getQueryParams :: [String] -> ClientM [Person]
|
||||
getQueryFlag :: Bool -> ClientM Bool
|
||||
getRawSuccess :: HTTP.Method -> ClientM Response
|
||||
getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response
|
||||
getRawFailure :: HTTP.Method -> ClientM Response
|
||||
getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])]
|
||||
-> ClientM (String, Maybe Int, Bool, [(String, [Rational])])
|
||||
|
|
@ -135,6 +137,7 @@ getRoot
|
|||
:<|> getQueryParams
|
||||
:<|> getQueryFlag
|
||||
:<|> getRawSuccess
|
||||
:<|> getRawSuccessPassHeaders
|
||||
:<|> getRawFailure
|
||||
:<|> getMultiple
|
||||
:<|> getRespHeaders
|
||||
|
|
@ -157,6 +160,7 @@ server = serve api (
|
|||
:<|> (\ names -> return (zipWith Person names [0..]))
|
||||
:<|> return
|
||||
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess")
|
||||
:<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess"))
|
||||
:<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure")
|
||||
:<|> (\ a b c d -> return (a, b, c, d))
|
||||
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ import Servant.API
|
|||
(NoContent (NoContent), getHeaders)
|
||||
import Servant.Client
|
||||
import qualified Servant.Client.Core.Request as Req
|
||||
import Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
|
||||
import Servant.Test.ComprehensiveAPI
|
||||
import Servant.ClientTestUtils
|
||||
|
||||
|
|
@ -125,11 +126,24 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do
|
||||
mgr <- C.newManager C.defaultManagerSettings
|
||||
cj <- atomically . newTVar $ C.createCookieJar []
|
||||
_ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj))
|
||||
_ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest)
|
||||
cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj)
|
||||
C.cookie_name <$> cookie `shouldBe` Just "testcookie"
|
||||
C.cookie_value <$> cookie `shouldBe` Just "test"
|
||||
|
||||
it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do
|
||||
mgr <- C.newManager C.defaultManagerSettings
|
||||
-- In proper situation, extra headers should probably be visible in API type.
|
||||
-- However, testing for response timeout is difficult, so we test with something which is easy to observe
|
||||
let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] }
|
||||
let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest }
|
||||
res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv
|
||||
case res of
|
||||
Left e ->
|
||||
assertFailure $ show e
|
||||
Right r ->
|
||||
("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True
|
||||
|
||||
modifyMaxSuccess (const 20) $ do
|
||||
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
|
||||
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
|
||||
|
|
@ -137,4 +151,3 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
|
|||
result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
|
||||
return $
|
||||
result === Right (cap, num, flag, body)
|
||||
|
||||
|
|
|
|||
|
|
@ -63,6 +63,6 @@ test-suite example
|
|||
, servant-server >=0.15 && <0.17
|
||||
, servant-client >=0.15 && <0.17
|
||||
, wai >=3.2.1.2 && <3.3
|
||||
, warp >=3.2.25 && <3.3
|
||||
, warp >=3.2.25 && <3.4
|
||||
, http-client
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -134,7 +134,8 @@ instance Semigroup API where
|
|||
(<>) = mappend
|
||||
|
||||
instance Monoid API where
|
||||
API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
|
||||
API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
|
||||
(HM.unionWith combineAction b1 b2)
|
||||
mempty = API mempty mempty
|
||||
|
||||
-- | An empty 'API'
|
||||
|
|
@ -243,6 +244,15 @@ data Response = Response
|
|||
, _respHeaders :: [HTTP.Header]
|
||||
} deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Combine two Responses, we can't make a monoid because merging Status breaks
|
||||
-- the laws.
|
||||
--
|
||||
-- As such, we invent a non-commutative, left associative operation
|
||||
-- 'combineResponse' to mush two together taking the status from the very left.
|
||||
combineResponse :: Response -> Response -> Response
|
||||
Response s ts bs hs `combineResponse` Response _ ts' bs' hs'
|
||||
= Response s (ts <> ts') (bs <> bs') (hs <> hs')
|
||||
|
||||
-- | Default response: status code 200, no response body.
|
||||
--
|
||||
-- Can be tweaked with four lenses.
|
||||
|
|
@ -287,11 +297,10 @@ data Action = Action
|
|||
-- laws.
|
||||
--
|
||||
-- As such, we invent a non-commutative, left associative operation
|
||||
-- 'combineAction' to mush two together taking the response, body and content
|
||||
-- types from the very left.
|
||||
-- 'combineAction' to mush two together taking the response from the very left.
|
||||
combineAction :: Action -> Action -> Action
|
||||
Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
|
||||
Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
|
||||
Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =
|
||||
Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
|
||||
|
||||
-- | Default 'Action'. Has no 'captures', no query 'params', expects
|
||||
-- no request body ('rqbody') and the typical response is 'defResponse'.
|
||||
|
|
|
|||
|
|
@ -73,8 +73,10 @@ spec = describe "Servant.Docs" $ do
|
|||
golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
|
||||
|
||||
describe "markdown" $ do
|
||||
let md = markdown (docs (Proxy :: Proxy TestApi1))
|
||||
tests md
|
||||
let md1 = markdown (docs (Proxy :: Proxy TestApi1))
|
||||
tests1 md1
|
||||
let md2 = markdown (docs (Proxy :: Proxy TestApi2))
|
||||
tests2 md2
|
||||
|
||||
describe "markdown with extra info" $ do
|
||||
let
|
||||
|
|
@ -86,7 +88,7 @@ spec = describe "Servant.Docs" $ do
|
|||
(Proxy :: Proxy ("postJson" :> ReqBody '[JSON] String :> Post '[JSON] Datatype1))
|
||||
(defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
|
||||
md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
|
||||
tests md
|
||||
tests1 md
|
||||
it "contains the extra info provided" $ do
|
||||
md `shouldContain` "Get an Integer"
|
||||
md `shouldContain` "Post data"
|
||||
|
|
@ -114,7 +116,7 @@ spec = describe "Servant.Docs" $ do
|
|||
|
||||
|
||||
where
|
||||
tests md = do
|
||||
tests1 md = do
|
||||
it "mentions supported content-types" $ do
|
||||
md `shouldContain` "application/json"
|
||||
md `shouldContain` "text/plain;charset=utf-8"
|
||||
|
|
@ -149,6 +151,11 @@ spec = describe "Servant.Docs" $ do
|
|||
it "does not generate any docs mentioning the 'empty-api' path" $
|
||||
md `shouldNotContain` "empty-api"
|
||||
|
||||
tests2 md = do
|
||||
it "mentions the content-types from both copies of the route" $ do
|
||||
md `shouldContain` "application/json"
|
||||
md `shouldContain` "text/plain;charset=utf-8"
|
||||
|
||||
|
||||
-- * APIs
|
||||
|
||||
|
|
@ -178,6 +185,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
|
|||
:<|> "header" :> Header "X-Test" Int :> Put '[JSON] Int
|
||||
:<|> "empty-api" :> EmptyAPI
|
||||
|
||||
type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1
|
||||
:<|> "duplicate-endpoint" :> Get '[PlainText] Int
|
||||
|
||||
|
||||
data TT = TT1 | TT2 deriving (Show, Eq)
|
||||
data UT = UT1 | UT2 deriving (Show, Eq)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,11 @@
|
|||
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/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.16.0.1
|
||||
--------
|
||||
|
||||
- Allow `base-compat-0.11`
|
||||
|
||||
0.16
|
||||
----
|
||||
|
||||
|
|
|
|||
|
|
@ -18,6 +18,8 @@ import Control.DeepSeq
|
|||
(NFData, force)
|
||||
import Control.Exception
|
||||
(IOException, SomeException (..), catch, evaluate, throwIO)
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Codensity
|
||||
|
|
@ -25,9 +27,13 @@ import Control.Monad.Codensity
|
|||
import Control.Monad.Error.Class
|
||||
(MonadError (..))
|
||||
import Control.Monad.IO.Class
|
||||
(liftIO)
|
||||
(MonadIO (..))
|
||||
import Control.Monad.Reader
|
||||
(MonadReader, ReaderT, ask, runReaderT)
|
||||
import Control.Monad.Trans.Class
|
||||
(lift)
|
||||
import Control.Monad.Trans.Except
|
||||
(ExceptT, runExceptT)
|
||||
import Data.Bifunctor
|
||||
(bimap, first)
|
||||
import Data.ByteString.Builder
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
X.Y
|
||||
----
|
||||
|
||||
Initial release
|
||||
|
|
@ -1,30 +0,0 @@
|
|||
Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Zalora South East Asia Pte Ltd nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
|
@ -1,15 +0,0 @@
|
|||
# `servant-client-jsaddle`
|
||||
|
||||
This is a an implementation of the `servant-client-core` API on top of `jsaddle`, a framework that lets you write Haskell programs that compile to javascript to run in a browser or compile to native code that connects to a browser.
|
||||
|
||||
It is similar to `servant-client-ghcjs`, except it supports native compilation and native GHCi. It even reuses some of the logic from `servant-client-ghcjs`.
|
||||
|
||||
# Build
|
||||
|
||||
This package comes with a test suite that depends on `jsaddle-webkit2gtk`. You may want to skip that because of the heavy dependency footprint.
|
||||
|
||||
cabal new-build --allow-newer=aeson,http-types --disable-tests
|
||||
|
||||
# Usage
|
||||
|
||||
TBD. Similar to `servant-client` and `servant-client-ghcjs`.
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
@ -1,125 +0,0 @@
|
|||
name: servant-jsaddle
|
||||
version: 0.16
|
||||
synopsis:
|
||||
automatic derivation of querying functions for servant webservices for jsaddle
|
||||
|
||||
description:
|
||||
This library lets you automatically derive Haskell functions that
|
||||
let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
|
||||
.
|
||||
See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
|
||||
.
|
||||
<https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
|
||||
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
copyright:
|
||||
2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
|
||||
|
||||
category: Servant, Web
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with:
|
||||
GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5
|
||||
, GHCJS ==8.4
|
||||
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
bug-reports: http://github.com/haskell-servant/servant/issues
|
||||
extra-source-files:
|
||||
CHANGELOG.md
|
||||
README.md
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
||||
library
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: src
|
||||
ghc-options: -Wall
|
||||
exposed-modules:
|
||||
Servant.Client.Internal.JSaddleXhrClient
|
||||
Servant.Client.JSaddle
|
||||
|
||||
-- Bundled with GHC: Lower bound to not force re-installs
|
||||
-- text and mtl are bundled starting with GHC-8.4
|
||||
build-depends:
|
||||
base >=4.9 && <4.13
|
||||
, bytestring >=0.10.8.1 && <0.11
|
||||
, containers >=0.5.7.1 && <0.7
|
||||
, mtl >=2.2.2 && <2.3
|
||||
, text >=1.2.3.0 && <1.3
|
||||
, transformers >=0.5.2.0 && <0.6
|
||||
|
||||
if impl(ghcjs -any)
|
||||
build-depends: ghcjs-base
|
||||
|
||||
-- Servant dependencies.
|
||||
-- Strict dependency on `servant-client-core` as we re-export things.
|
||||
build-depends: servant-client-core >=0.16 && <0.16.1
|
||||
build-depends:
|
||||
base-compat >=0.10.5 && <0.11
|
||||
, case-insensitive >=1.2.0.0 && <1.3
|
||||
, exceptions >=0.10.0 && <0.11
|
||||
, ghcjs-dom
|
||||
, http-media >=0.7.1.3 && <0.9
|
||||
, http-types >=0.12.2 && <0.13
|
||||
, jsaddle >=0.9.6.0 && <0.10
|
||||
, monad-control >=1.0.2.3 && <1.1
|
||||
, semigroupoids >=5.3.1 && <5.4
|
||||
, string-conversions >=0.3 && <0.5
|
||||
, transformers-base >=0.4.4 && <0.5
|
||||
|
||||
if impl(ghc >=8.0)
|
||||
ghc-options: -Wno-redundant-constraints
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options: -Wall
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
|
||||
if impl(ghcjs -any)
|
||||
build-depends:
|
||||
base
|
||||
, servant-jsaddle
|
||||
|
||||
else
|
||||
other-modules: Servant.Client.JSaddleSpec
|
||||
|
||||
-- Dependencies inherited from the library. No need to specify bounds.
|
||||
build-depends:
|
||||
base
|
||||
, bytestring
|
||||
, containers
|
||||
, exceptions
|
||||
, ghcjs-dom
|
||||
, http-media
|
||||
, http-types
|
||||
, jsaddle
|
||||
, mtl
|
||||
, process
|
||||
, semigroupoids
|
||||
, servant
|
||||
, servant-client-core
|
||||
, servant-jsaddle
|
||||
, servant-server
|
||||
, string-conversions
|
||||
, text
|
||||
, wai
|
||||
, wai-cors
|
||||
, wai-extra
|
||||
, warp
|
||||
, websockets
|
||||
|
||||
-- Additonal dependencies
|
||||
build-depends:
|
||||
aeson
|
||||
, hspec
|
||||
, jsaddle-warp
|
||||
, QuickCheck
|
||||
|
||||
build-tool-depends: hspec-discover:hspec-discover >=2.4.4 && <2.5
|
||||
|
|
@ -1,311 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
module Servant.Client.Internal.JSaddleXhrClient where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Concurrent
|
||||
(MVar, newEmptyMVar, takeMVar, tryPutMVar)
|
||||
import Control.Exception
|
||||
(Exception, toException)
|
||||
import Control.Monad
|
||||
(forM_, unless, void)
|
||||
import Control.Monad.Catch
|
||||
(MonadCatch, MonadThrow, catch)
|
||||
import Control.Monad.Error.Class
|
||||
(MonadError (..))
|
||||
import Control.Monad.IO.Class
|
||||
(MonadIO (..))
|
||||
import Control.Monad.Reader
|
||||
(MonadReader, ReaderT, asks, runReaderT)
|
||||
import Control.Monad.Trans.Except
|
||||
(ExceptT, runExceptT)
|
||||
import Data.Bifunctor
|
||||
(bimap, first, second)
|
||||
import Data.ByteString.Builder
|
||||
(toLazyByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.CaseInsensitive
|
||||
(mk, original)
|
||||
import Data.Char
|
||||
(isSpace)
|
||||
import Data.Foldable
|
||||
(toList)
|
||||
import Data.Functor.Alt
|
||||
(Alt (..))
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.String.Conversions
|
||||
(cs)
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text.Encoding.Error as T
|
||||
import GHC.Generics
|
||||
import qualified GHCJS.Buffer as Buffer
|
||||
import qualified GHCJS.DOM
|
||||
import qualified GHCJS.DOM.EventM as JSDOM
|
||||
import qualified GHCJS.DOM.Location as Location
|
||||
import GHCJS.DOM.Types
|
||||
(DOM, DOMContext, askDOM, runDOM)
|
||||
import qualified GHCJS.DOM.Types as JS
|
||||
import qualified GHCJS.DOM.Window as Window
|
||||
import qualified GHCJS.DOM.XMLHttpRequest as JS
|
||||
import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer
|
||||
import qualified Language.Javascript.JSaddle.Types as JSaddle
|
||||
import Network.HTTP.Media
|
||||
(renderHeader)
|
||||
import Network.HTTP.Types
|
||||
(ResponseHeaders, http11, mkStatus, renderQuery, statusCode)
|
||||
import System.IO
|
||||
(hPutStrLn, stderr)
|
||||
|
||||
import Servant.Client.Core
|
||||
|
||||
-- Note: assuming encoding UTF-8
|
||||
|
||||
data ClientEnv
|
||||
= ClientEnv
|
||||
{ baseUrl :: BaseUrl
|
||||
-- | Modify the XMLHttpRequest at will, right before sending.
|
||||
, fixUpXhr :: JS.XMLHttpRequest -> DOM ()
|
||||
}
|
||||
|
||||
data JSaddleConnectionError = JSaddleConnectionError
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Exception JSaddleConnectionError
|
||||
|
||||
-- | Default 'ClientEnv'
|
||||
mkClientEnv :: BaseUrl -> ClientEnv
|
||||
mkClientEnv burl = ClientEnv burl (const (pure ()))
|
||||
|
||||
instance Show ClientEnv where
|
||||
showsPrec prec (ClientEnv burl _) =
|
||||
showParen (prec >= 11)
|
||||
( showString "ClientEnv {"
|
||||
. showString "baseUrl = "
|
||||
. showsPrec 0 burl
|
||||
. showString ", fixUpXhr = <function>"
|
||||
. showString "}"
|
||||
)
|
||||
|
||||
client :: HasClient ClientM api => Proxy api -> Client ClientM api
|
||||
client api = api `clientIn` (Proxy :: Proxy ClientM)
|
||||
|
||||
newtype ClientM a = ClientM
|
||||
{ fromClientM :: ReaderT ClientEnv (ExceptT ClientError DOM) a }
|
||||
deriving ( Functor, Applicative, Monad, MonadIO, Generic
|
||||
, MonadReader ClientEnv, MonadError ClientError)
|
||||
deriving instance MonadThrow DOM => MonadThrow ClientM
|
||||
deriving instance MonadCatch DOM => MonadCatch ClientM
|
||||
|
||||
-- | Try clients in order, last error is preserved.
|
||||
instance Alt ClientM where
|
||||
a <!> b = a `catchError` const b
|
||||
|
||||
instance RunClient ClientM where
|
||||
throwClientError = throwError
|
||||
runRequest r = do
|
||||
d <- ClientM askDOM
|
||||
performRequest d r
|
||||
|
||||
runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
|
||||
runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm
|
||||
|
||||
runClientM' :: ClientM a -> DOM (Either ClientError a)
|
||||
runClientM' m = do
|
||||
burl <- getDefaultBaseUrl
|
||||
runClientM m (mkClientEnv burl)
|
||||
|
||||
getDefaultBaseUrl :: DOM BaseUrl
|
||||
getDefaultBaseUrl = do
|
||||
win <- GHCJS.DOM.currentWindow >>= \mw -> case mw of
|
||||
Just x -> pure x
|
||||
Nothing -> fail "Can not determine default base url without window."
|
||||
curLoc <- Window.getLocation win
|
||||
|
||||
protocolStr <- Location.getProtocol curLoc
|
||||
portStr <- Location.getPort curLoc
|
||||
hostname <- Location.getHostname curLoc
|
||||
|
||||
let protocol
|
||||
| (protocolStr :: JS.JSString) == "https:"
|
||||
= Https
|
||||
| otherwise = Http
|
||||
|
||||
port :: Int
|
||||
port | null portStr = case protocol of
|
||||
Http -> 80
|
||||
Https -> 443
|
||||
| otherwise = read portStr
|
||||
|
||||
pure (BaseUrl protocol hostname port "")
|
||||
|
||||
performRequest :: DOMContext -> Request -> ClientM Response
|
||||
performRequest domc req = do
|
||||
xhr <- JS.newXMLHttpRequest `runDOM` domc
|
||||
burl <- asks baseUrl
|
||||
fixUp <- asks fixUpXhr
|
||||
performXhr xhr burl req fixUp `runDOM` domc
|
||||
resp <- toResponse domc xhr
|
||||
|
||||
let status = statusCode (responseStatusCode resp)
|
||||
unless (status >= 200 && status < 300) $
|
||||
throwError $ mkFailureResponse burl req resp
|
||||
|
||||
pure resp
|
||||
|
||||
|
||||
-- * performing requests
|
||||
-- Performs the xhr and blocks until the response was received
|
||||
performXhr :: JS.XMLHttpRequest -> BaseUrl -> Request -> (JS.XMLHttpRequest -> DOM ()) -> DOM ()
|
||||
performXhr xhr burl request fixUp = do
|
||||
|
||||
let username, password :: Maybe JS.JSString
|
||||
username = Nothing; password = Nothing
|
||||
|
||||
JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password
|
||||
setHeaders xhr request
|
||||
fixUp xhr
|
||||
|
||||
waiter <- liftIO $ newEmptyMVar
|
||||
|
||||
cleanup <- JSDOM.on xhr JS.readyStateChange $ do
|
||||
state <- JS.getReadyState xhr
|
||||
case state of
|
||||
-- onReadyStateChange's callback can fire state 4
|
||||
-- (which means "request finished and response is ready")
|
||||
-- multiple times. By using tryPutMVar, only the first time
|
||||
-- state 4 is fired will cause an MVar to be put. Subsequent
|
||||
-- fires are ignored.
|
||||
4 -> void $ liftIO $ tryPutMVar waiter ()
|
||||
_ -> return ()
|
||||
|
||||
sendXhr xhr (toBody request) `catch` handleXHRError waiter -- We handle any errors in `toResponse`.
|
||||
|
||||
liftIO $ takeMVar waiter
|
||||
|
||||
cleanup
|
||||
|
||||
where
|
||||
|
||||
handleXHRError :: MVar () -> JS.XHRError -> DOM ()
|
||||
handleXHRError waiter e = do
|
||||
liftIO $ hPutStrLn stderr $ "servant-client-jsaddle: exception in `sendXhr` (should get handled in response handling): " <> show e
|
||||
void $ liftIO $ tryPutMVar waiter ()
|
||||
|
||||
|
||||
toUrl :: BaseUrl -> Request -> JS.JSString
|
||||
toUrl burl request =
|
||||
let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $
|
||||
requestPath request
|
||||
queryS =
|
||||
JS.toJSString $ decodeUtf8Lenient $
|
||||
renderQuery True $
|
||||
toList $
|
||||
requestQueryString request
|
||||
in JS.toJSString (showBaseUrl burl) <> pathS <> queryS :: JS.JSString
|
||||
|
||||
setHeaders :: JS.XMLHttpRequest -> Request -> DOM ()
|
||||
setHeaders xhr request = do
|
||||
forM_ (toList $ requestAccept request) $ \mediaType -> -- FIXME review
|
||||
JS.setRequestHeader
|
||||
xhr
|
||||
("Accept" :: JS.JSString)
|
||||
(decodeUtf8Lenient $ renderHeader mediaType)
|
||||
|
||||
forM_ (requestBody request) $ \(_, mediaType) ->
|
||||
JS.setRequestHeader
|
||||
xhr
|
||||
("Content-Type" :: JS.JSString)
|
||||
(decodeUtf8Lenient $ renderHeader mediaType)
|
||||
|
||||
forM_ (toList $ requestHeaders request) $ \(key, value) ->
|
||||
JS.setRequestHeader xhr (decodeUtf8Lenient $ original key) (decodeUtf8Lenient value)
|
||||
|
||||
-- ArrayBufferView is a type that only exists in the spec and covers many concrete types.
|
||||
castMutableArrayBufferToArrayBufferView :: ArrayBuffer.MutableArrayBuffer -> DOM JS.ArrayBufferView
|
||||
castMutableArrayBufferToArrayBufferView x = JS.liftJSM $ do
|
||||
JS.fromJSValUnchecked $ JS.pToJSVal x
|
||||
|
||||
mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
|
||||
mkFailureResponse burl request =
|
||||
FailureResponse (bimap (const ()) f request)
|
||||
where
|
||||
f b = (burl, BSL.toStrict $ toLazyByteString b)
|
||||
|
||||
sendXhr :: JS.XMLHttpRequest -> Maybe L.ByteString -> DOM ()
|
||||
sendXhr xhr Nothing = JS.send xhr
|
||||
sendXhr xhr (Just body) = do
|
||||
-- Reason for copy: hopefully offset will be 0 and length b == len
|
||||
-- FIXME: use a typed array constructor that accepts offset and length and skip the copy
|
||||
(b, _offset, _len) <- JSaddle.ghcjsPure $ Buffer.fromByteString $ BS.copy $ L.toStrict body
|
||||
b' <- Buffer.thaw b
|
||||
b'' <- JSaddle.ghcjsPure $ Buffer.getArrayBuffer b'
|
||||
JS.sendArrayBuffer xhr =<< castMutableArrayBufferToArrayBufferView b''
|
||||
|
||||
toBody :: Request -> Maybe L.ByteString
|
||||
toBody request = case requestBody request of
|
||||
Nothing -> Nothing
|
||||
Just (RequestBodyLBS "", _) -> Nothing
|
||||
Just (RequestBodyLBS x, _) -> Just x
|
||||
Just (RequestBodyBS "", _) -> Nothing
|
||||
Just (RequestBodyBS x, _) -> Just $ L.fromStrict x
|
||||
Just (RequestBodySource _, _) -> error "RequestBodySource isn't supported"
|
||||
|
||||
-- * inspecting the xhr response
|
||||
|
||||
-- This function is only supposed to handle 'ConnectionError's. Other
|
||||
-- 'ClientError's are created in Servant.Client.Req.
|
||||
toResponse :: DOMContext -> JS.XMLHttpRequest -> ClientM Response
|
||||
toResponse domc xhr = do
|
||||
let inDom :: DOM a -> ClientM a
|
||||
inDom = flip runDOM domc
|
||||
status <- inDom $ JS.getStatus xhr
|
||||
case status of
|
||||
0 -> throwError $ ConnectionError $ toException JSaddleConnectionError
|
||||
_ -> inDom $ do
|
||||
statusText <- BS.pack <$> JS.getStatusText xhr
|
||||
headers <- parseHeaders <$> JS.getAllResponseHeaders xhr
|
||||
responseText <- maybe "" (L.fromStrict . BS.pack) <$> JS.getResponseText xhr -- FIXME: Text/Binary? Performance? Test?
|
||||
pure Response
|
||||
{ responseStatusCode = mkStatus (fromIntegral status) statusText
|
||||
, responseBody = responseText
|
||||
, responseHeaders = Seq.fromList headers
|
||||
, responseHttpVersion = http11 -- this is made up
|
||||
}
|
||||
|
||||
parseHeaders :: String -> ResponseHeaders
|
||||
parseHeaders s =
|
||||
(first mk . first strip . second strip . parseHeader) <$>
|
||||
splitOn "\r\n" (cs s)
|
||||
where
|
||||
parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
||||
parseHeader h = case BS.breakSubstring ":" (cs h) of
|
||||
(key, BS.drop 1 -> value) -> (key, value)
|
||||
|
||||
splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
|
||||
splitOn separator input = case BS.breakSubstring separator input of
|
||||
(prefix, "") -> [prefix]
|
||||
(prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
|
||||
|
||||
strip :: BS.ByteString -> BS.ByteString
|
||||
strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
|
||||
|
||||
decodeUtf8Lenient :: BS.ByteString -> JS.JSString
|
||||
decodeUtf8Lenient = JS.toJSString . T.decodeUtf8With T.lenientDecode
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
-- | This module provides 'client' which can automatically generate
|
||||
-- querying functions for each endpoint just from the type representing your
|
||||
-- API.
|
||||
module Servant.Client.JSaddle
|
||||
(
|
||||
client
|
||||
, ClientM
|
||||
, runClientM
|
||||
, runClientM'
|
||||
|
||||
-- * Configuration
|
||||
, ClientEnv(..)
|
||||
, mkClientEnv
|
||||
, getDefaultBaseUrl
|
||||
|
||||
, module Servant.Client.Core.Reexport
|
||||
) where
|
||||
|
||||
import Servant.Client.Internal.JSaddleXhrClient
|
||||
import Servant.Client.Core.Reexport
|
||||
|
|
@ -1,163 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.Client.JSaddleSpec where
|
||||
|
||||
import Control.Concurrent
|
||||
(threadDelay)
|
||||
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
|
||||
import Control.Monad.Trans
|
||||
import Data.Aeson
|
||||
import Data.ByteString
|
||||
(ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.Proxy
|
||||
import Data.String
|
||||
import Data.Word
|
||||
import GHC.Generics
|
||||
import qualified GHCJS.DOM
|
||||
import qualified GHCJS.DOM.Window as Window
|
||||
import Language.Javascript.JSaddle.Monad
|
||||
(JSM)
|
||||
import qualified Language.Javascript.JSaddle.Monad as JSaddle
|
||||
import qualified Language.Javascript.JSaddle.Run as Run
|
||||
import qualified Language.Javascript.JSaddle.WebSockets as WS
|
||||
import qualified Network.HTTP.Types as Http
|
||||
import qualified Network.Wai as Wai
|
||||
import Network.Wai.Handler.Warp as Warp
|
||||
import qualified System.Process as P
|
||||
import Network.Wai.Middleware.AddHeaders
|
||||
import Network.Wai.Middleware.Cors
|
||||
(simpleCors)
|
||||
import Network.WebSockets
|
||||
(defaultConnectionOptions)
|
||||
import Servant.API
|
||||
import Servant.Client.JSaddle
|
||||
import Servant.Server
|
||||
import Test.Hspec
|
||||
|
||||
type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse
|
||||
testApi :: Proxy TestApi
|
||||
testApi = Proxy
|
||||
|
||||
data TestResponse = TestResponse { byteList :: [Word8] }
|
||||
deriving (Generic, ToJSON, FromJSON, Show, Eq)
|
||||
|
||||
testServer :: Server TestApi
|
||||
testServer x = do
|
||||
pure . TestResponse . B.unpack $ x
|
||||
|
||||
testClient :: Client ClientM TestApi
|
||||
testClient = client testApi
|
||||
|
||||
-- WARNING: approximation!
|
||||
jsaddleFinally :: JSM b -> JSM a -> JSM a
|
||||
jsaddleFinally handler m = JSaddle.bracket (pure ()) (const handler) (const m)
|
||||
-- jsaddleFinally handler m = JSaddle.catch (m <* handler) (\e -> handler >> throw (e :: SomeException))
|
||||
|
||||
close :: JSM ()
|
||||
close = do
|
||||
mw <- GHCJS.DOM.currentWindow
|
||||
case mw of
|
||||
Just w -> do
|
||||
liftIO $ putStrLn "Closing window..."
|
||||
Window.close w
|
||||
Nothing -> liftIO $ putStrLn "Can't close the window!"
|
||||
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "Servant.Client.JSaddle" $ do
|
||||
it "Receive a properly encoded response" $ do
|
||||
-- A mvar to tell promptly when we are done
|
||||
done <- newEmptyMVar
|
||||
|
||||
-- How this work:
|
||||
--
|
||||
-- 1. we start server warp, which serves simple API
|
||||
-- 2. we start client warp, which serves jsaddle running the 'action'
|
||||
-- 3. we run google-chrome-stable to open jsaddle page and to run the test
|
||||
|
||||
let action :: Int -> JSM ()
|
||||
action serverPort = do
|
||||
liftIO $ threadDelay $ 500 * 1000
|
||||
-- a mix of valid utf-8 and non-utf8 bytes
|
||||
let bytes = [0x01, 0xff, 0x02, 0xfe, 0x03, 0xfd, 0x00, 0x64, 0xc3, 0xbb, 0x68, 0xc3]
|
||||
response <- flip runClientM clientEnv $ testClient (B.pack bytes)
|
||||
liftIO $ print response
|
||||
liftIO $ response `shouldBe` Right (TestResponse bytes)
|
||||
|
||||
-- we are done.
|
||||
liftIO $ putMVar done ()
|
||||
where
|
||||
clientEnv = mkClientEnv BaseUrl
|
||||
{ baseUrlScheme = Http
|
||||
, baseUrlHost = "localhost"
|
||||
, baseUrlPort = fromIntegral serverPort
|
||||
, baseUrlPath = "/"
|
||||
}
|
||||
|
||||
let serverApp :: IO Application
|
||||
serverApp = pure $ logRequest $ addCors $ serve testApi testServer
|
||||
|
||||
Warp.testWithApplication serverApp $ \serverPort -> do
|
||||
|
||||
let clientApp :: IO Application
|
||||
clientApp = WS.jsaddleOr defaultConnectionOptions (action serverPort >> Run.syncPoint) WS.jsaddleApp
|
||||
|
||||
Warp.testWithApplication (simpleCors <$> clientApp) $ \clientPort -> do
|
||||
putStrLn $ "server http://localhost:" ++ show serverPort
|
||||
putStrLn $ "client http://localhost:" ++ show clientPort
|
||||
putStrLn $ "google-chrome-stable --headless --disable-gpu --screenshot http://localhost:" ++ show clientPort
|
||||
|
||||
-- threadDelay $ 1000 * 1000 * 1000
|
||||
|
||||
-- Run headless chrome
|
||||
-- https://docs.travis-ci.com/user/gui-and-headless-browsers/#using-the-chrome-addon-in-the-headless-mode
|
||||
-- https://developers.google.com/web/updates/2017/04/headless-chrome
|
||||
hdl <- P.spawnProcess "google-chrome-stable"
|
||||
[ "--headless"
|
||||
, "--disable-gpu"
|
||||
, "--remote-debugging-port=9222" -- TODO: bind to random port
|
||||
, "http://localhost:" ++ show clientPort
|
||||
]
|
||||
|
||||
-- wait for test to run.
|
||||
takeMVar done
|
||||
|
||||
-- kill chrome
|
||||
P.terminateProcess hdl
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Logger middleware
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
logRequest :: Wai.Middleware
|
||||
logRequest app request respond = do
|
||||
putStrLn "Request"
|
||||
print request
|
||||
app request $ \response -> do
|
||||
putStrLn "Response Headers"
|
||||
mapM_ print (Wai.responseHeaders response)
|
||||
respond response
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- OPTIONS
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
corsHeaders :: (IsString s1, IsString s2) => [(s1, s2)]
|
||||
corsHeaders =
|
||||
[ ("Access-Control-Allow-Origin", "*")
|
||||
, ("Access-Control-Allow-Methods", "POST")
|
||||
, ("Access-Control-Allow-Headers", "content-type")
|
||||
]
|
||||
|
||||
addCors :: Wai.Middleware
|
||||
addCors app request respond =
|
||||
if Wai.requestMethod request == "OPTIONS"
|
||||
then respond $ Wai.responseLBS Http.status200 corsHeaders ""
|
||||
else addHeaders corsHeaders app request respond
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
#ifdef __GHCJS__
|
||||
module Main (main) where
|
||||
main :: IO ()
|
||||
main = return ()
|
||||
#else
|
||||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
||||
#endif
|
||||
|
|
@ -60,6 +60,6 @@ test-suite example
|
|||
, servant-server >=0.15 && <0.17
|
||||
, servant-client >=0.15 && <0.17
|
||||
, wai >=3.2.1.2 && <3.3
|
||||
, warp >=3.2.25 && <3.3
|
||||
, warp >=3.2.25 && <3.4
|
||||
, http-client
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -63,6 +63,6 @@ test-suite example
|
|||
, servant-server >=0.15 && <0.17
|
||||
, servant-client >=0.15 && <0.17
|
||||
, wai >=3.2.1.2 && <3.3
|
||||
, warp >=3.2.25 && <3.3
|
||||
, warp >=3.2.25 && <3.4
|
||||
, http-client
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -1,33 +1,2 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
module Main (main) where
|
||||
|
||||
#ifndef MIN_VERSION_cabal_doctest
|
||||
#define MIN_VERSION_cabal_doctest(x,y,z) 0
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_cabal_doctest(1,0,0)
|
||||
|
||||
import Distribution.Extra.Doctest ( defaultMainWithDoctests )
|
||||
main :: IO ()
|
||||
main = defaultMainWithDoctests "doctests"
|
||||
|
||||
#else
|
||||
|
||||
#ifdef MIN_VERSION_Cabal
|
||||
-- If the macro is defined, we have new cabal-install,
|
||||
-- but for some reason we don't have cabal-doctest in package-db
|
||||
--
|
||||
-- Probably we are running cabal sdist, when otherwise using new-build
|
||||
-- workflow
|
||||
#warning You are configuring this package without cabal-doctest installed. \
|
||||
The doctests test-suite will not work as a result. \
|
||||
To fix this, install cabal-doctest before configuring.
|
||||
#endif
|
||||
|
||||
import Distribution.Simple
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ license-file: LICENSE
|
|||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
|
||||
build-type: Custom
|
||||
build-type: Simple
|
||||
tested-with:
|
||||
GHC ==8.0.2
|
||||
|| ==8.2.2
|
||||
|
|
@ -38,12 +38,6 @@ source-repository head
|
|||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
||||
custom-setup
|
||||
setup-depends:
|
||||
base >= 4 && <5,
|
||||
Cabal,
|
||||
cabal-doctest >= 1.0.6 && <1.1
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Servant
|
||||
|
|
@ -121,7 +115,7 @@ executable greet
|
|||
|
||||
build-depends:
|
||||
aeson >= 1.4.1.0 && < 1.5
|
||||
, warp >= 3.2.25 && < 3.3
|
||||
, warp >= 3.2.25 && < 3.4
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
|
|
@ -166,7 +160,7 @@ test-suite spec
|
|||
aeson >= 1.4.1.0 && < 1.5
|
||||
, directory >= 1.3.0.0 && < 1.4
|
||||
, hspec >= 2.6.0 && < 2.8
|
||||
, hspec-wai >= 0.9.0 && < 0.10
|
||||
, hspec-wai >= 0.10.1 && < 0.11
|
||||
, QuickCheck >= 2.12.6.1 && < 2.14
|
||||
, should-not-typecheck >= 2.1.0 && < 2.2
|
||||
, temporary >= 1.3 && < 1.4
|
||||
|
|
@ -174,16 +168,3 @@ test-suite spec
|
|||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.6.0 && <2.8
|
||||
|
||||
test-suite doctests
|
||||
build-depends:
|
||||
base
|
||||
, servant-server
|
||||
, doctest >= 0.16.0 && <0.17
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: test/doctests.hs
|
||||
buildable: True
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -threaded
|
||||
if impl(ghc >= 8.2)
|
||||
x-doctest-options: -fdiagnostics-color=never
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ import Network.Socket
|
|||
(SockAddr)
|
||||
import Network.Wai
|
||||
(Application, Request, httpVersion, isSecure, lazyRequestBody,
|
||||
rawQueryString, remoteHost, requestBody, requestHeaders,
|
||||
queryString, rawQueryString, remoteHost, requestBody, requestHeaders,
|
||||
requestMethod, responseLBS, responseStream, vault)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
|
@ -80,7 +80,7 @@ import Servant.API
|
|||
import Servant.API.ContentTypes
|
||||
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
|
||||
AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH,
|
||||
NoContent (NoContent))
|
||||
NoContent)
|
||||
import Servant.API.Modifiers
|
||||
(FoldLenient, FoldRequired, RequestArgument,
|
||||
unfoldRequestArgument)
|
||||
|
|
@ -91,7 +91,7 @@ import Web.FormUrlEncoded
|
|||
import qualified Servant.Types.SourceT as S
|
||||
import Web.HttpApiData
|
||||
(FromHttpApiData, parseHeader, parseQueryParam,
|
||||
parseUrlPieceMaybe, parseUrlPieces, parseUrlPiece)
|
||||
parseUrlPieces, parseUrlPiece)
|
||||
|
||||
import Servant.Server.Internal.BasicAuth
|
||||
import Servant.Server.Internal.Context
|
||||
|
|
@ -274,7 +274,7 @@ noContentRouter method status action = leafRouter route'
|
|||
where
|
||||
route' env request respond =
|
||||
runAction (action `addMethodCheck` methodCheck method request)
|
||||
env request respond $ \ output ->
|
||||
env request respond $ \ _output ->
|
||||
Route $ responseLBS status [] ""
|
||||
|
||||
instance {-# OVERLAPPABLE #-}
|
||||
|
|
@ -454,7 +454,7 @@ instance
|
|||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context subserver =
|
||||
let querytext req = parseQueryText $ rawQueryString req
|
||||
let querytext = queryToQueryText . queryString
|
||||
paramname = cs $ symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
parseParam :: Request -> DelayedIO (RequestArgument mods a)
|
||||
|
|
@ -521,8 +521,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context)
|
|||
params :: [T.Text]
|
||||
params = mapMaybe snd
|
||||
. filter (looksLikeParam . fst)
|
||||
. parseQueryText
|
||||
. rawQueryString
|
||||
. queryToQueryText
|
||||
. queryString
|
||||
$ req
|
||||
|
||||
looksLikeParam name = name == paramname || name == (paramname <> "[]")
|
||||
|
|
@ -548,7 +548,7 @@ instance (KnownSymbol sym, HasServer api context)
|
|||
hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s
|
||||
|
||||
route Proxy context subserver =
|
||||
let querytext r = parseQueryText $ rawQueryString r
|
||||
let querytext = queryToQueryText . queryString
|
||||
param r = case lookup paramname (querytext r) of
|
||||
Just Nothing -> True -- param is there, with no value
|
||||
Just (Just v) -> examine v -- param with a value
|
||||
|
|
|
|||
|
|
@ -12,13 +12,12 @@ import Control.Monad.Reader
|
|||
import Control.Monad.Trans
|
||||
(MonadIO (..), MonadTrans (..))
|
||||
import Control.Monad.Trans.Control
|
||||
(ComposeSt, MonadBaseControl (..), MonadTransControl (..),
|
||||
defaultLiftBaseWith, defaultRestoreM)
|
||||
(MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Resource
|
||||
(MonadResource (..), ResourceT, runInternalState,
|
||||
runResourceT, transResourceT, withInternalState)
|
||||
transResourceT, withInternalState)
|
||||
import Network.Wai
|
||||
(Application, Request, Response, ResponseReceived)
|
||||
(Request)
|
||||
|
||||
import Servant.Server.Internal.RouteResult
|
||||
import Servant.Server.Internal.ServerError
|
||||
|
|
|
|||
|
|
@ -25,6 +25,8 @@ import qualified Data.ByteString as BS
|
|||
import qualified Data.ByteString.Base64 as Base64
|
||||
import Data.Char
|
||||
(toUpper)
|
||||
import Data.Maybe
|
||||
(fromMaybe)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Data.String
|
||||
|
|
@ -35,26 +37,26 @@ import qualified Data.Text as T
|
|||
import GHC.Generics
|
||||
(Generic)
|
||||
import Network.HTTP.Types
|
||||
(Status (..), hAccept, hContentType, imATeapot418,
|
||||
(QueryItem, Status (..), hAccept, hContentType, imATeapot418,
|
||||
methodDelete, methodGet, methodHead, methodPatch, methodPost,
|
||||
methodPut, ok200, parseQuery)
|
||||
import Network.Wai
|
||||
(Application, Request, pathInfo, queryString, rawQueryString,
|
||||
requestHeaders, responseLBS)
|
||||
(Application, Middleware, Request, pathInfo, queryString,
|
||||
rawQueryString, requestHeaders, responseLBS)
|
||||
import Network.Wai.Test
|
||||
(defaultRequest, request, runSession, simpleBody,
|
||||
simpleHeaders, simpleStatus)
|
||||
import Servant.API
|
||||
((:<|>) (..), (:>), AuthProtect, BasicAuth,
|
||||
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Lenient, Strict, Delete,
|
||||
EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
|
||||
JSON, NoContent (..), NoFraming, OctetStream, Patch,
|
||||
PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, QueryParamForm, Raw,
|
||||
RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,
|
||||
NoContentVerb, addHeader)
|
||||
BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
|
||||
Delete, EmptyAPI, Get, Header, Headers, HttpVersion,
|
||||
IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
|
||||
NoFraming, OctetStream, Patch, PlainText, Post, Put,
|
||||
QueryFlag, QueryParam, QueryParams, QueryParamForm, Raw, RemoteHost, ReqBody,
|
||||
SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader)
|
||||
import Servant.Server
|
||||
(Context ((:.), EmptyContext), Handler, Server, Tagged (..),
|
||||
emptyServer, err400, err401, err403, err404, serve, serveWithContext)
|
||||
emptyServer, err401, err403, err404, serve, serveWithContext)
|
||||
import Servant.Test.ComprehensiveAPI
|
||||
import qualified Servant.Types.SourceT as S
|
||||
import Test.Hspec
|
||||
|
|
@ -221,7 +223,7 @@ captureServer = getLegs :<|> getEars :<|> getEyes
|
|||
_ -> throwError err404
|
||||
|
||||
getEars :: Either String Integer -> Handler Animal
|
||||
getEars (Left e) = return chimera -- ignore integer parse error, return weird animal
|
||||
getEars (Left _) = return chimera -- ignore integer parse error, return weird animal
|
||||
getEars (Right 2) = return jerry
|
||||
getEars (Right _) = throwError err404
|
||||
|
||||
|
|
@ -342,116 +344,122 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAge
|
|||
queryParamServer (Just name_) = return alice{name = name_}
|
||||
queryParamServer Nothing = return alice
|
||||
|
||||
|
||||
|
||||
queryParamSpec :: Spec
|
||||
queryParamSpec = do
|
||||
let mkRequest params pinfo = Network.Wai.Test.request defaultRequest
|
||||
{ rawQueryString = params
|
||||
, queryString = parseQuery params
|
||||
, pathInfo = pinfo
|
||||
}
|
||||
|
||||
describe "Servant.API.QueryParam" $ do
|
||||
it "allows retrieving simple GET parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params1 = "?name=bob"
|
||||
response1 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params1,
|
||||
queryString = parseQuery params1
|
||||
}
|
||||
liftIO $ do
|
||||
decode' (simpleBody response1) `shouldBe` Just alice{
|
||||
name = "bob"
|
||||
flip runSession (serve queryParamApi qpServer) $ do
|
||||
response1 <- mkRequest "?name=bob" []
|
||||
liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
|
||||
{ name = "bob"
|
||||
}
|
||||
|
||||
it "allows retrieving lists in GET parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params2 = "?names[]=bob&names[]=john"
|
||||
response2 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params2,
|
||||
queryString = parseQuery params2,
|
||||
pathInfo = ["a"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response2) `shouldBe` Just alice{
|
||||
name = "john"
|
||||
flip runSession (serve queryParamApi qpServer) $ do
|
||||
response2 <- mkRequest "?names[]=bob&names[]=john" ["a"]
|
||||
liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
|
||||
{ name = "john"
|
||||
}
|
||||
|
||||
it "parses a query parameter" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params = "?age=55"
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params,
|
||||
queryString = parseQuery params,
|
||||
pathInfo = ["param"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response) `shouldBe` Just alice{
|
||||
age = 55
|
||||
flip runSession (serve queryParamApi qpServer) $ do
|
||||
response <- mkRequest "?age=55" ["param"]
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
{ age = 55
|
||||
}
|
||||
|
||||
it "generates an error on query parameter parse failure" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params = "?age=foo"
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params,
|
||||
queryString = parseQuery params,
|
||||
pathInfo = ["param"]
|
||||
}
|
||||
flip runSession (serve queryParamApi qpServer) $ do
|
||||
response <- mkRequest "?age=foo" ["param"]
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` 400
|
||||
return ()
|
||||
|
||||
it "parses multiple query parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params = "?ages=10&ages=22"
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params,
|
||||
queryString = parseQuery params,
|
||||
pathInfo = ["multiparam"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response) `shouldBe` Just alice{
|
||||
age = 32
|
||||
flip runSession (serve queryParamApi qpServer) $ do
|
||||
response <- mkRequest "?ages=10&ages=22" ["multiparam"]
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
{ age = 32
|
||||
}
|
||||
|
||||
it "generates an error on parse failures of multiple parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params = "?ages=2&ages=foo"
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params,
|
||||
queryString = parseQuery params,
|
||||
pathInfo = ["multiparam"]
|
||||
}
|
||||
flip runSession (serve queryParamApi qpServer) $ do
|
||||
response <- mkRequest "?ages=2&ages=foo" ["multiparam"]
|
||||
liftIO $ statusCode (simpleStatus response) `shouldBe` 400
|
||||
return ()
|
||||
|
||||
it "allows retrieving value-less GET parameters" $
|
||||
flip runSession (serve queryParamApi qpServer) $ do
|
||||
response3 <- mkRequest "?capitalize" ["b"]
|
||||
liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
|
||||
{ name = "ALICE"
|
||||
}
|
||||
|
||||
response3' <- mkRequest "?capitalize=" ["b"]
|
||||
liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
|
||||
{ name = "ALICE"
|
||||
}
|
||||
|
||||
response3'' <- mkRequest "?unknown=" ["b"]
|
||||
liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
|
||||
{ name = "Alice"
|
||||
}
|
||||
|
||||
describe "Uses queryString instead of rawQueryString" $ do
|
||||
-- test query parameters rewriter
|
||||
let queryRewriter :: Middleware
|
||||
queryRewriter app req = app req
|
||||
{ queryString = fmap rewrite $ queryString req
|
||||
}
|
||||
where
|
||||
rewrite :: QueryItem -> QueryItem
|
||||
rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v)
|
||||
|
||||
let app = queryRewriter $ serve queryParamApi qpServer
|
||||
|
||||
it "allows rewriting for simple GET/query parameters" $
|
||||
flip runSession app $ do
|
||||
response1 <- mkRequest "?person_name=bob" []
|
||||
liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
|
||||
{ name = "bob"
|
||||
}
|
||||
|
||||
it "allows rewriting for lists in GET parameters" $
|
||||
flip runSession app $ do
|
||||
response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"]
|
||||
liftIO $ decode' (simpleBody response2) `shouldBe` Just alice
|
||||
{ name = "john"
|
||||
}
|
||||
|
||||
it "allows rewriting when parsing multiple query parameters" $
|
||||
flip runSession app $ do
|
||||
response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"]
|
||||
liftIO $ decode' (simpleBody response) `shouldBe` Just alice
|
||||
{ age = 32
|
||||
}
|
||||
|
||||
it "allows retrieving value-less GET parameters" $
|
||||
(flip runSession) (serve queryParamApi qpServer) $ do
|
||||
let params3 = "?capitalize"
|
||||
response3 <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3,
|
||||
queryString = parseQuery params3,
|
||||
pathInfo = ["b"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3) `shouldBe` Just alice{
|
||||
name = "ALICE"
|
||||
flip runSession app $ do
|
||||
response3 <- mkRequest "?person_capitalize" ["b"]
|
||||
liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
|
||||
{ name = "ALICE"
|
||||
}
|
||||
|
||||
let params3' = "?capitalize="
|
||||
response3' <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3',
|
||||
queryString = parseQuery params3',
|
||||
pathInfo = ["b"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3') `shouldBe` Just alice{
|
||||
name = "ALICE"
|
||||
response3' <- mkRequest "?person_capitalize=" ["b"]
|
||||
liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
|
||||
{ name = "ALICE"
|
||||
}
|
||||
|
||||
let params3'' = "?unknown="
|
||||
response3'' <- Network.Wai.Test.request defaultRequest{
|
||||
rawQueryString = params3'',
|
||||
queryString = parseQuery params3'',
|
||||
pathInfo = ["b"]
|
||||
}
|
||||
liftIO $
|
||||
decode' (simpleBody response3'') `shouldBe` Just alice{
|
||||
name = "Alice"
|
||||
response3'' <- mkRequest "?person_unknown=" ["b"]
|
||||
liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
|
||||
{ name = "Alice"
|
||||
}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
|
@ -665,7 +673,7 @@ rawSpec :: Spec
|
|||
rawSpec = do
|
||||
describe "Servant.API.Raw" $ do
|
||||
it "runs applications" $ do
|
||||
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
|
||||
flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["foo"]
|
||||
}
|
||||
|
|
@ -673,7 +681,7 @@ rawSpec = do
|
|||
simpleBody response `shouldBe` "42"
|
||||
|
||||
it "gets the pathInfo modified" $ do
|
||||
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
|
||||
flip runSession (serve rawApi (rawApplication pathInfo)) $ do
|
||||
response <- Network.Wai.Test.request defaultRequest{
|
||||
pathInfo = ["foo", "bar"]
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,27 +0,0 @@
|
|||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Main (doctests)
|
||||
-- Copyright : (C) 2012-14 Edward Kmett
|
||||
-- License : BSD-style (see the file LICENSE)
|
||||
-- Maintainer : Edward Kmett <ekmett@gmail.com>
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
--
|
||||
-- This module provides doctests for a project based on the actual versions
|
||||
-- of the packages it was built with. It requires a corresponding Setup.lhs
|
||||
-- to be added to the project
|
||||
-----------------------------------------------------------------------------
|
||||
module Main where
|
||||
|
||||
import Build_doctests
|
||||
(flags, module_sources, pkgs)
|
||||
import Data.Foldable
|
||||
(traverse_)
|
||||
import Test.DocTest
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
traverse_ putStrLn args
|
||||
doctest args
|
||||
where
|
||||
args = flags ++ pkgs ++ module_sources
|
||||
|
|
@ -1,33 +1,2 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# OPTIONS_GHC -Wall #-}
|
||||
module Main (main) where
|
||||
|
||||
#ifndef MIN_VERSION_cabal_doctest
|
||||
#define MIN_VERSION_cabal_doctest(x,y,z) 0
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_cabal_doctest(1,0,0)
|
||||
|
||||
import Distribution.Extra.Doctest ( defaultMainWithDoctests )
|
||||
main :: IO ()
|
||||
main = defaultMainWithDoctests "doctests"
|
||||
|
||||
#else
|
||||
|
||||
#ifdef MIN_VERSION_Cabal
|
||||
-- If the macro is defined, we have new cabal-install,
|
||||
-- but for some reason we don't have cabal-doctest in package-db
|
||||
--
|
||||
-- Probably we are running cabal sdist, when otherwise using new-build
|
||||
-- workflow
|
||||
#warning You are configuring this package without cabal-doctest installed. \
|
||||
The doctests test-suite will not work as a result. \
|
||||
To fix this, install cabal-doctest before configuring.
|
||||
#endif
|
||||
|
||||
import Distribution.Simple
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ license-file: LICENSE
|
|||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors
|
||||
build-type: Custom
|
||||
build-type: Simple
|
||||
|
||||
tested-with:
|
||||
GHC ==8.0.2
|
||||
|
|
@ -35,12 +35,6 @@ source-repository head
|
|||
type: git
|
||||
location: http://github.com/haskell-servant/servant.git
|
||||
|
||||
custom-setup
|
||||
setup-depends:
|
||||
base >= 4 && <5,
|
||||
Cabal,
|
||||
cabal-doctest >= 1.0.6 && <1.1
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Servant.API
|
||||
|
|
@ -177,26 +171,3 @@ test-suite spec
|
|||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.6.0 && < 2.8
|
||||
|
||||
test-suite doctests
|
||||
if impl(ghcjs)
|
||||
buildable: False
|
||||
|
||||
build-depends:
|
||||
base
|
||||
, servant
|
||||
, doctest >= 0.16.0 && <0.17
|
||||
|
||||
-- We test Links failure with doctest, so we need extra dependencies
|
||||
build-depends:
|
||||
hspec >= 2.6.0 && < 2.8
|
||||
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: test/doctests.hs
|
||||
buildable: True
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -threaded
|
||||
if impl(ghc >= 8.2)
|
||||
x-doctest-options: -fdiagnostics-color=never
|
||||
x-doctest-source-dirs: test
|
||||
x-doctest-modules: Servant.LinksSpec
|
||||
|
|
|
|||
|
|
@ -39,14 +39,14 @@ data Summary (sym :: Symbol)
|
|||
--type MyApi = Description
|
||||
-- "This comment is visible in multiple Servant interpretations \
|
||||
-- \and can be really long if necessary. \
|
||||
-- \Haskell multiline support is not perfect \
|
||||
-- \Haskell multiline String support is not perfect \
|
||||
-- \but it's still very readable."
|
||||
-- :> Get '[JSON] Book
|
||||
-- :}
|
||||
data Description (sym :: Symbol)
|
||||
deriving (Typeable)
|
||||
|
||||
-- | Fold modifier list to decide whether argument should be parsed strictly or leniently.
|
||||
-- | Fold list of modifiers to extract description as a type-level String.
|
||||
--
|
||||
-- >>> :kind! FoldDescription '[]
|
||||
-- FoldDescription '[] :: Symbol
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ import Data.Typeable
|
|||
-- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'.
|
||||
--
|
||||
-- In addition to just letting you plug in your existing WAI 'Application's,
|
||||
-- this can also be used with <https://hackage.haskell.org/package/servant-server/docs/Servant-Utils-StaticFiles.html#v:serveDirectory serveDirectory> to serve
|
||||
-- static files stored in a particular directory on your filesystem
|
||||
-- this can also be used with functions from
|
||||
-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
|
||||
-- to serve static files stored in a particular directory on your filesystem
|
||||
data Raw deriving Typeable
|
||||
|
|
|
|||
|
|
@ -179,7 +179,7 @@ type family IsStrictSubAPI sub api :: Constraint where
|
|||
|
||||
-- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@).
|
||||
--
|
||||
-- ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI))
|
||||
-- >>> ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI))
|
||||
-- OK
|
||||
type family AllIsIn xs api :: Constraint where
|
||||
AllIsIn '[] api = ()
|
||||
|
|
|
|||
|
|
@ -133,6 +133,9 @@ spec = describe "Servant.Links" $ do
|
|||
let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw
|
||||
firstLink `shouldBeLink` ""
|
||||
|
||||
-- The doctests below aren't run on CI, setting that up is tricky.
|
||||
-- They are run by makefile rule, however.
|
||||
|
||||
-- |
|
||||
-- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed,
|
||||
-- we'll just use doctest
|
||||
|
|
|
|||
|
|
@ -1,27 +0,0 @@
|
|||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Main (doctests)
|
||||
-- Copyright : (C) 2012-14 Edward Kmett
|
||||
-- License : BSD-style (see the file LICENSE)
|
||||
-- Maintainer : Edward Kmett <ekmett@gmail.com>
|
||||
-- Stability : provisional
|
||||
-- Portability : portable
|
||||
--
|
||||
-- This module provides doctests for a project based on the actual versions
|
||||
-- of the packages it was built with. It requires a corresponding Setup.lhs
|
||||
-- to be added to the project
|
||||
-----------------------------------------------------------------------------
|
||||
module Main where
|
||||
|
||||
import Build_doctests
|
||||
(flags, module_sources, pkgs)
|
||||
import Data.Foldable
|
||||
(traverse_)
|
||||
import Test.DocTest
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
traverse_ putStrLn args
|
||||
doctest args
|
||||
where
|
||||
args = flags ++ pkgs ++ module_sources
|
||||
21
stack.yaml
21
stack.yaml
|
|
@ -1,10 +1,10 @@
|
|||
# Let's try to keep resolver at the first day of the month
|
||||
resolver: nightly-2018-09-28 # Last nightly with GHC-8.4.3
|
||||
resolver: lts-14.17
|
||||
packages:
|
||||
- servant-client/
|
||||
- servant-client-core/
|
||||
- servant-client/
|
||||
- servant-docs/
|
||||
- servant-foreign/
|
||||
- servant-http-streams/
|
||||
- servant-server/
|
||||
- servant/
|
||||
|
||||
|
|
@ -16,17 +16,4 @@ packages:
|
|||
# - doc/tutorial/
|
||||
|
||||
extra-deps:
|
||||
- base-compat-0.10.5
|
||||
- conduit-1.3.1
|
||||
- hspec-2.6.0
|
||||
- hspec-core-2.6.0
|
||||
- hspec-discover-2.6.0
|
||||
- http-api-data-0.4
|
||||
- http-media-0.7.1.3
|
||||
- network-2.8.0.0
|
||||
- pipes-safe-2.3.1
|
||||
- QuickCheck-2.12.6.1
|
||||
- resourcet-1.2.2
|
||||
- sop-core-0.4.0.0
|
||||
- wai-extra-3.0.24.3
|
||||
- tasty-1.1.0.4
|
||||
- hspec-wai-0.10.1
|
||||
|
|
|
|||
Loading…
Reference in a new issue