diff --git a/.travis.yml b/.travis.yml index 6ae8bd58..4f839a90 100644 --- a/.travis.yml +++ b/.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 '?')]" @@ -104,21 +85,29 @@ install: - HEADHACKAGE=false - rm -f $CABALHOME/config - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config + echo "remote-build-reporting: anonymous" >> $CABALHOME/config + echo "write-ghc-environment-files: always" >> $CABALHOME/config + echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config + echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config + echo "world-file: $CABALHOME/world" >> $CABALHOME/config + echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config + echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config + echo "installdir: $CABALHOME/bin" >> $CABALHOME/config + echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config + echo "store-dir: $CABALHOME/store" >> $CABALHOME/config + echo "install-dirs user" >> $CABALHOME/config + 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 () { 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 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 82e66a5d..46eb65f7 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -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 diff --git a/Makefile b/Makefile index 34180491..2caf4c05 100644 --- a/Makefile +++ b/Makefile @@ -20,3 +20,13 @@ build-ghcjs : packdeps : packdeps */*.cabal + +doctest : doctest-servant doctest-servant-server + perl -i -e 'while () { 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) diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 023c5323..ac041d53 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -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 diff --git a/cabal.project b/cabal.project index 9d6e3fdd..4f29900b 100644 --- a/cabal.project +++ b/cabal.project @@ -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 diff --git a/changelog.d/config b/changelog.d/config new file mode 100644 index 00000000..bb3c2c48 --- /dev/null +++ b/changelog.d/config @@ -0,0 +1,2 @@ +organization: haskell-servant +repository: servant diff --git a/changelog.d/issue1028 b/changelog.d/issue1028 new file mode 100644 index 00000000..73cede30 --- /dev/null +++ b/changelog.d/issue1028 @@ -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. + +} diff --git a/changelog.d/issue1200 b/changelog.d/issue1200 new file mode 100644 index 00000000..885a2571 --- /dev/null +++ b/changelog.d/issue1200 @@ -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. + +} diff --git a/changelog.d/issue1240 b/changelog.d/issue1240 new file mode 100644 index 00000000..dce11a69 --- /dev/null +++ b/changelog.d/issue1240 @@ -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. + +} diff --git a/changelog.d/jsaddle b/changelog.d/jsaddle new file mode 100644 index 00000000..02dcf5b4 --- /dev/null +++ b/changelog.d/jsaddle @@ -0,0 +1,3 @@ +synopsis: Progress on servant-jsaddle +packages: servant-jsaddle +prs: #1216 diff --git a/changelog.d/pr1156 b/changelog.d/pr1156 new file mode 100644 index 00000000..91726ae9 --- /dev/null +++ b/changelog.d/pr1156 @@ -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. + +} diff --git a/changelog.d/pr1190 b/changelog.d/pr1190 new file mode 100644 index 00000000..e6a308c4 --- /dev/null +++ b/changelog.d/pr1190 @@ -0,0 +1,7 @@ +synopsis: Add sponsorship button +prs: #1190 +description: { + +[Well-Typed](https://www.well-typed.com/) + +} diff --git a/changelog.d/pr1194 b/changelog.d/pr1194 new file mode 100644 index 00000000..53136662 --- /dev/null +++ b/changelog.d/pr1194 @@ -0,0 +1,3 @@ +synopsis: Prevent race-conditions in testing +packages: servant-docs +prs: #1194 diff --git a/changelog.d/pr1197 b/changelog.d/pr1197 new file mode 100644 index 00000000..bc041c62 --- /dev/null +++ b/changelog.d/pr1197 @@ -0,0 +1,4 @@ +synopsis: `HasClient` instance for `Stream` with `Headers` +packages: servant-client servant-client servant-http-streams +prs: #1197 +issues: #1170 diff --git a/changelog.d/pr1201 b/changelog.d/pr1201 new file mode 100644 index 00000000..0724fc38 --- /dev/null +++ b/changelog.d/pr1201 @@ -0,0 +1,3 @@ +synopsis: Remove unused extensions from cabal file +packages: servant +prs: #1201 diff --git a/changelog.d/pr1213 b/changelog.d/pr1213 new file mode 100644 index 00000000..3cb5f15b --- /dev/null +++ b/changelog.d/pr1213 @@ -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. + +} diff --git a/changelog.d/pr1238 b/changelog.d/pr1238 new file mode 100644 index 00000000..5b0d838c --- /dev/null +++ b/changelog.d/pr1238 @@ -0,0 +1,3 @@ +synopsis: Redact the authorization header in Show and exceptions +packages: servant-client +prs: #1238 diff --git a/changelog.d/pr1249 b/changelog.d/pr1249 new file mode 100644 index 00000000..3a5c772a --- /dev/null +++ b/changelog.d/pr1249 @@ -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. + +} diff --git a/changelog.d/pr1263 b/changelog.d/pr1263 new file mode 100644 index 00000000..593bcd1b --- /dev/null +++ b/changelog.d/pr1263 @@ -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). + +} diff --git a/changelog.d/z-changelog-d b/changelog.d/z-changelog-d new file mode 100644 index 00000000..c7e027ff --- /dev/null +++ b/changelog.d/z-changelog-d @@ -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 + +} diff --git a/changelog.d/z-ci-tweaks b/changelog.d/z-ci-tweaks new file mode 100644 index 00000000..331e5679 --- /dev/null +++ b/changelog.d/z-ci-tweaks @@ -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. + +} diff --git a/changelog.d/z-cookbook b/changelog.d/z-cookbook new file mode 100644 index 00000000..71dca975 --- /dev/null +++ b/changelog.d/z-cookbook @@ -0,0 +1,9 @@ +synopsis: New cookbook recipes +prs: #1171 #1088 #1198 + +description: { + +- [OIDC Recipe](#TODO) +- [MySQL Recipe](#TODO) + +} diff --git a/changelog.d/z-dependency-upgrades b/changelog.d/z-dependency-upgrades new file mode 100644 index 00000000..43d72ef0 --- /dev/null +++ b/changelog.d/z-dependency-upgrades @@ -0,0 +1,9 @@ +synopsis: Dependency upgrades +prs: + #1173 + #1181 + #1183 + #1188 + #1224 + #1245 + #1257 diff --git a/changelog.d/z-documentation-updates b/changelog.d/z-documentation-updates new file mode 100644 index 00000000..3d8b2215 --- /dev/null +++ b/changelog.d/z-documentation-updates @@ -0,0 +1,8 @@ +synopsis: Documentation updates +prs: + #1162 + #1174 + #1175 + #1234 + #1244 + #1247 diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs index fe64b6eb..d72ad6d5 100644 --- a/doc/cookbook/using-free-client/UsingFreeClient.lhs +++ b/doc/cookbook/using-free-client/UsingFreeClient.lhs @@ -2,7 +2,7 @@ or simply put: _a practical introduction to `Servant.Client.Free`_. -Someone asked on IRC how one could access the intermediate Requests (resp. Responses) +Someone asked on IRC how one could access the intermediate Requests (resp. Responses) produced (resp. received) by client functions derived using servant-client. My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging purposes), use `Servant.Client.Free`. This recipe shows how. @@ -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' ``` @@ -136,11 +136,11 @@ and calling the continuation. We should get a `Pure` value. ```haskell let res = I.clientResponseToResponse id res' - + case k res of Pure n -> putStrLn $ "Expected 1764, got " ++ show n - _ -> + _ -> putStrLn "ERROR: didn't got a response" ``` @@ -153,7 +153,7 @@ and responses available for us to inspect, since `RunClient` only gives us access to one `Request` or `Response` at a time. On the other hand, a "batch collection" of requests and/or responses can be achieved -with both free clients and a custom `RunClient` instance rather easily, for example +with both free clients and a custom `RunClient` instance rather easily, for example by using a `Writer [(Request, Response)]` monad. Here is an example of running our small `test` against a running server: diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index e1e9e58a..da18b7ee 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -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 diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 00c2f26e..404ea027 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -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: diff --git a/doc/tutorial/test/Spec.hs b/doc/tutorial/test/Spec.hs index a824f8c3..4808302a 100644 --- a/doc/tutorial/test/Spec.hs +++ b/doc/tutorial/test/Spec.hs @@ -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 diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index d68dad30..ce245b65 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -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 diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 55495411..f7dcf4a8 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -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: diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index bd36b895..16568b80 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Request.hs @@ -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", "") + redactSensitiveHeader h = h instance Bifunctor RequestF where bimap = bimapDefault instance Bifoldable RequestF where bifoldMap = bifoldMapDefault instance Bitraversable RequestF where diff --git a/servant-client-core/test/Servant/Client/Core/RequestSpec.hs b/servant-client-core/test/Servant/Client/Core/RequestSpec.hs new file mode 100644 index 00000000..99a1db7d --- /dev/null +++ b/servant-client-core/test/Servant/Client/Core/RequestSpec.hs @@ -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 diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index aa144cab..02f7bd85 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -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 ---- diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 5c8268fc..dd7356f1 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 1ecc07db..e0c8dab5 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -9,6 +9,7 @@ module Servant.Client , runClientM , ClientEnv(..) , mkClientEnv + , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 1feb56d6..c25c8a93 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -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 diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 449c638d..2f5a1cb7 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -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 diff --git a/servant-client/src/Servant/Client/Streaming.hs b/servant-client/src/Servant/Client/Streaming.hs index d4e8721d..5800df0d 100644 --- a/servant-client/src/Servant/Client/Streaming.hs +++ b/servant-client/src/Servant/Client/Streaming.hs @@ -10,6 +10,7 @@ module Servant.Client.Streaming , runClientM , ClientEnv(..) , mkClientEnv + , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 1509574c..6f385010 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -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) diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index d16cfd79..272b607c 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -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) - diff --git a/servant-conduit/servant-conduit.cabal b/servant-conduit/servant-conduit.cabal index e1247803..4aec51d8 100644 --- a/servant-conduit/servant-conduit.cabal +++ b/servant-conduit/servant-conduit.cabal @@ -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 diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 54c16a83..bd4360c3 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -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'. diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 32ffce11..4d18f7e2 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -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) diff --git a/servant-http-streams/CHANGELOG.md b/servant-http-streams/CHANGELOG.md index 7bf14e4f..19b1f6b1 100644 --- a/servant-http-streams/CHANGELOG.md +++ b/servant-http-streams/CHANGELOG.md @@ -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 ---- diff --git a/servant-http-streams/src/Servant/HttpStreams/Internal.hs b/servant-http-streams/src/Servant/HttpStreams/Internal.hs index 3c5fb7e4..54c920bc 100644 --- a/servant-http-streams/src/Servant/HttpStreams/Internal.hs +++ b/servant-http-streams/src/Servant/HttpStreams/Internal.hs @@ -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 diff --git a/servant-jsaddle/CHANGELOG.md b/servant-jsaddle/CHANGELOG.md deleted file mode 100644 index 53231096..00000000 --- a/servant-jsaddle/CHANGELOG.md +++ /dev/null @@ -1,4 +0,0 @@ -X.Y ----- - -Initial release diff --git a/servant-jsaddle/LICENSE b/servant-jsaddle/LICENSE deleted file mode 100644 index 9717a9ce..00000000 --- a/servant-jsaddle/LICENSE +++ /dev/null @@ -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. diff --git a/servant-jsaddle/README.md b/servant-jsaddle/README.md deleted file mode 100644 index ada9aeef..00000000 --- a/servant-jsaddle/README.md +++ /dev/null @@ -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`. diff --git a/servant-jsaddle/Setup.hs b/servant-jsaddle/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-jsaddle/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-jsaddle/servant-jsaddle.cabal b/servant-jsaddle/servant-jsaddle.cabal deleted file mode 100644 index c9904056..00000000 --- a/servant-jsaddle/servant-jsaddle.cabal +++ /dev/null @@ -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 webservice. - . - See . - . - - -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 diff --git a/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs b/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs deleted file mode 100644 index e219ff2e..00000000 --- a/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs +++ /dev/null @@ -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 = " - . 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 diff --git a/servant-jsaddle/src/Servant/Client/JSaddle.hs b/servant-jsaddle/src/Servant/Client/JSaddle.hs deleted file mode 100644 index f3a65ce1..00000000 --- a/servant-jsaddle/src/Servant/Client/JSaddle.hs +++ /dev/null @@ -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 diff --git a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs deleted file mode 100644 index 759fbebe..00000000 --- a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs +++ /dev/null @@ -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 diff --git a/servant-jsaddle/test/Spec.hs b/servant-jsaddle/test/Spec.hs deleted file mode 100644 index 394ef87e..00000000 --- a/servant-jsaddle/test/Spec.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef __GHCJS__ -module Main (main) where -main :: IO () -main = return () -#else -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -#endif diff --git a/servant-machines/servant-machines.cabal b/servant-machines/servant-machines.cabal index 80aeb450..31f1de7d 100644 --- a/servant-machines/servant-machines.cabal +++ b/servant-machines/servant-machines.cabal @@ -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 diff --git a/servant-pipes/servant-pipes.cabal b/servant-pipes/servant-pipes.cabal index 480ddd26..5fdc4b5a 100644 --- a/servant-pipes/servant-pipes.cabal +++ b/servant-pipes/servant-pipes.cabal @@ -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 diff --git a/servant-server/Setup.hs b/servant-server/Setup.hs index 8ec54a08..44671092 100644 --- a/servant-server/Setup.hs +++ b/servant-server/Setup.hs @@ -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 () +import Distribution.Simple main = defaultMain - -#endif diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index fe12cfdb..27defcae 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -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 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 8a3ac8d9..988e4ecb 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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 diff --git a/servant-server/src/Servant/Server/Internal/DelayedIO.hs b/servant-server/src/Servant/Server/Internal/DelayedIO.hs index 52b6aff5..48f35b9d 100644 --- a/servant-server/src/Servant/Server/Internal/DelayedIO.hs +++ b/servant-server/src/Servant/Server/Internal/DelayedIO.hs @@ -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 diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 5f023363..e71c2015 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -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,117 +344,123 @@ 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" - } - - 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" - } - - 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 + 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 + 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 + 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 - 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 (serve queryParamApi qpServer) $ do + response3 <- mkRequest "?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 "?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 "?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 app $ do + response3 <- mkRequest "?person_capitalize" ["b"] + liftIO $ decode' (simpleBody response3) `shouldBe` Just alice + { name = "ALICE" + } + + response3' <- mkRequest "?person_capitalize=" ["b"] + liftIO $ decode' (simpleBody response3') `shouldBe` Just alice + { name = "ALICE" + } + + response3'' <- mkRequest "?person_unknown=" ["b"] + liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice + { name = "Alice" + } ------------------------------------------------------------------------------ -- * queryParamFormSpec {{{ @@ -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"] } diff --git a/servant-server/test/doctests.hs b/servant-server/test/doctests.hs deleted file mode 100644 index c27aa580..00000000 --- a/servant-server/test/doctests.hs +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- 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 diff --git a/servant/Setup.hs b/servant/Setup.hs index 8ec54a08..44671092 100644 --- a/servant/Setup.hs +++ b/servant/Setup.hs @@ -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 () +import Distribution.Simple main = defaultMain - -#endif diff --git a/servant/servant.cabal b/servant/servant.cabal index 2417e80d..120fce72 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -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 diff --git a/servant/src/Servant/API/Description.hs b/servant/src/Servant/API/Description.hs index b7996650..18c54322 100644 --- a/servant/src/Servant/API/Description.hs +++ b/servant/src/Servant/API/Description.hs @@ -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 diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index 0624298c..4ece3845 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -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 to serve --- static files stored in a particular directory on your filesystem +-- this can also be used with functions from +-- +-- to serve static files stored in a particular directory on your filesystem data Raw deriving Typeable diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index a4e0c86a..862cae22 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -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 = () diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index f3940dc6..98450cc2 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -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 diff --git a/servant/test/doctests.hs b/servant/test/doctests.hs deleted file mode 100644 index c27aa580..00000000 --- a/servant/test/doctests.hs +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- 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 diff --git a/stack.yaml b/stack.yaml index a4855c36..491c55b1 100644 --- a/stack.yaml +++ b/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