Merge master and fix conflicts

.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 "verbose: normal +nowrap +markoutput"                                  >> $CABALHOME/config
-    echo "remote-build-reporting: anonymous"            >> $CABALHOME/config
+    echo "remote-build-reporting: anonymous"                                    >> $CABALHOME/config
-    echo "write-ghc-environment-files: always"          >> $CABALHOME/config
+    echo "write-ghc-environment-files: always"                                  >> $CABALHOME/config
-    echo "remote-repo-cache: $CABALHOME/packages"       >> $CABALHOME/config
+    echo "remote-repo-cache: $CABALHOME/packages"                               >> $CABALHOME/config
-    echo "logs-dir:          $CABALHOME/logs"           >> $CABALHOME/config
+    echo "logs-dir:          $CABALHOME/logs"                                   >> $CABALHOME/config
-    echo "world-file:        $CABALHOME/world"          >> $CABALHOME/config
+    echo "world-file:        $CABALHOME/world"                                  >> $CABALHOME/config
-    echo "extra-prog-path:   $CABALHOME/bin"            >> $CABALHOME/config
+    echo "extra-prog-path:   $CABALHOME/bin"                                    >> $CABALHOME/config
-    echo "symlink-bindir:    $CABALHOME/bin"            >> $CABALHOME/config
+    echo "symlink-bindir:    $CABALHOME/bin"                                    >> $CABALHOME/config
-    echo "installdir:        $CABALHOME/bin"            >> $CABALHOME/config
+    echo "installdir:        $CABALHOME/bin"                                    >> $CABALHOME/config
-    echo "build-summary:     $CABALHOME/logs/build.log" >> $CABALHOME/config
+    echo "build-summary:     $CABALHOME/logs/build.log"                         >> $CABALHOME/config
-    echo "store-dir:         $CABALHOME/store"          >> $CABALHOME/config
+    echo "store-dir:         $CABALHOME/store"                                  >> $CABALHOME/config
-    echo "install-dirs user"                            >> $CABALHOME/config
+    echo "install-dirs user"                                                    >> $CABALHOME/config
-    echo "  prefix: $CABALHOME"                         >> $CABALHOME/config
+    echo "  prefix: $CABALHOME"                                                 >> $CABALHOME/config
-    echo "repository hackage.haskell.org"               >> $CABALHOME/config
+    echo "repository hackage.haskell.org"                                       >> $CABALHOME/config
-    echo "  url: http://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 $WITHCOMPILER -j2 doctest --constraint='doctest ==0.16.2.*') ; 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 -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe') ; fi
+  - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover) ; fi
   # Generate cabal.project
   - rm -rf cabal.project cabal.project.local cabal.project.freeze
   - touch cabal.project
@@ -143,7 +133,6 @@ install:
     if ! $GHCJS ; then echo "packages: servant-machines" >> cabal.project ; fi
     if ! $GHCJS ; then echo "packages: servant-conduit" >> cabal.project ; fi
     if ! $GHCJS ; then echo "packages: servant-pipes" >> cabal.project ; fi
-    if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then echo "packages: servant-jsaddle" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi
@@ -159,6 +148,7 @@ install:
     echo "constraints:  foundation >=0.0.14"               >> cabal.project
     echo "constraints:  memory <0.14.12 || >0.14.12"       >> cabal.project
     echo "constraints:  sqlite-simple < 0"                 >> cabal.project
+    echo "constraints:  base-compat ^>=0.11"               >> cabal.project
     echo "allow-newer:  aeson-pretty-0.8.7:base-compat"    >> cabal.project
     echo "allow-newer:  vault-0.3.1.2:hashable"            >> cabal.project
     echo "allow-newer:  psqueues-0.2.7.1:hashable"         >> cabal.project
@@ -168,7 +158,7 @@ install:
     echo "allow-newer:  io-streams-1.5.1.0:primitive"      >> cabal.project
     echo "allow-newer:  openssl-streams-1.2.2.0:network"   >> cabal.project
     echo "optimization: False"                             >> cabal.project
-  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
+  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
   - cat cabal.project || true
   - cat cabal.project.local || true
   - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi
@@ -182,7 +172,6 @@ install:
   - if [ -f "servant-machines/configure.ac" ]; then (cd "servant-machines" && autoreconf -i); fi
   - if [ -f "servant-conduit/configure.ac" ]; then (cd "servant-conduit" && autoreconf -i); fi
   - if [ -f "servant-pipes/configure.ac" ]; then (cd "servant-pipes" && autoreconf -i); fi
-  - if [ -f "servant-jsaddle/configure.ac" ]; then (cd "servant-jsaddle" && autoreconf -i); fi
   - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then (cd "doc/cookbook/basic-auth" && autoreconf -i); fi
   - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then (cd "doc/cookbook/curl-mock" && autoreconf -i); fi
   - if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then (cd "doc/cookbook/basic-streaming" && autoreconf -i); fi
@@ -194,14 +183,14 @@ install:
   - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi
   - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi
   - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi
-  - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
+  - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
   - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
   - rm  cabal.project.freeze
 script:
   - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
   # Packaging...
   - echo 'Packaging...' && echo -en 'travis_fold:start:sdist\\r'
-  - ${CABAL} v2-sdist all | color_cabal_output
+  - ${CABAL} v2-sdist all
   - echo -en 'travis_fold:end:sdist\\r'
   # Unpacking...
   - echo 'Unpacking...' && echo -en 'travis_fold:start:unpack\\r'
@@ -220,7 +209,6 @@ script:
   - PKGDIR_servant_machines="$(find . -maxdepth 1 -type d -regex '.*/servant-machines-[0-9.]*')"
   - PKGDIR_servant_conduit="$(find . -maxdepth 1 -type d -regex '.*/servant-conduit-[0-9.]*')"
   - PKGDIR_servant_pipes="$(find . -maxdepth 1 -type d -regex '.*/servant-pipes-[0-9.]*')"
-  - PKGDIR_servant_jsaddle="$(find . -maxdepth 1 -type d -regex '.*/servant-jsaddle-[0-9.]*')"
   - PKGDIR_cookbook_basic_auth="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-auth-[0-9.]*')"
   - PKGDIR_cookbook_curl_mock="$(find . -maxdepth 1 -type d -regex '.*/cookbook-curl-mock-[0-9.]*')"
   - PKGDIR_cookbook_basic_streaming="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-streaming-[0-9.]*')"
@@ -247,7 +235,6 @@ script:
     if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_machines}" >> cabal.project ; fi
     if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_conduit}" >> cabal.project ; fi
     if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi
-    if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then echo "packages: ${PKGDIR_servant_jsaddle}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi
     if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi
@@ -263,6 +250,7 @@ script:
     echo "constraints:  foundation >=0.0.14"               >> cabal.project
     echo "constraints:  memory <0.14.12 || >0.14.12"       >> cabal.project
     echo "constraints:  sqlite-simple < 0"                 >> cabal.project
+    echo "constraints:  base-compat ^>=0.11"               >> cabal.project
     echo "allow-newer:  aeson-pretty-0.8.7:base-compat"    >> cabal.project
     echo "allow-newer:  vault-0.3.1.2:hashable"            >> cabal.project
     echo "allow-newer:  psqueues-0.2.7.1:hashable"         >> cabal.project
@@ -272,7 +260,7 @@ script:
     echo "allow-newer:  io-streams-1.5.1.0:primitive"      >> cabal.project
     echo "allow-newer:  openssl-streams-1.2.2.0:network"   >> cabal.project
     echo "optimization: False"                             >> cabal.project
-  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
+  - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
   - cat cabal.project || true
   - cat cabal.project.local || true
   - |
@@ -289,7 +277,6 @@ script:
         servant-machines) echo ${PKGDIR_servant_machines} ;;
         servant-conduit) echo ${PKGDIR_servant_conduit} ;;
         servant-pipes) echo ${PKGDIR_servant_pipes} ;;
-        servant-jsaddle) echo ${PKGDIR_servant_jsaddle} ;;
         cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;;
         cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;;
         cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;;
@@ -307,15 +294,29 @@ script:
   # Building with tests and benchmarks...
   - echo 'Building with tests and benchmarks...' && echo -en 'travis_fold:start:build-everything\\r'
   # build & run tests, build benchmarks
-  - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
+  - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
   - echo -en 'travis_fold:end:build-everything\\r'
   # Testing...
-  - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
+  - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all ; fi
   - if $GHCJS ; then cabal-plan list-bins '*:test:*' | while read -r line; do testpkg=$(echo "$line" | perl -pe 's/:.*//'); testexe=$(echo "$line" | awk '{ print $2 }'); echo "testing $textexe in package $textpkg"; (cd "$(pkgdir $testpkg)" && nodejs "$testexe".jsexe/all.js); done ; fi
+  # Doctest...
+  - echo 'Doctest...' && echo -en 'travis_fold:start:doctest\\r'
+  - perl -i -e 'while (<ARGV>) { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.*
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_client} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_client_core} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_http_streams} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_docs} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_foreign} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_server} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_machines} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_conduit} && doctest  src) ; fi
+  - if ! $GHCJS ; then (cd ${PKGDIR_servant_pipes} && doctest  src) ; fi
+  - echo -en 'travis_fold:end:doctest\\r'
   # haddock...
   - echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r'
-  - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi
+  - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi
   - echo -en 'travis_fold:end:haddock\\r'
 
-# REGENDATA ["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]
+# REGENDATA ("0.9.20200110",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"])
 # EOF

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
 

Makefile

@@ -20,3 +20,13 @@ build-ghcjs :
 
 packdeps :
 	packdeps */*.cabal
+
+doctest : doctest-servant doctest-servant-server
+	perl -i -e 'while (<ARGV>) { print unless /package-id\s+base-compat-\d+(\.\d+)*/; }' .ghc.environment.*
+
+doctest-servant :
+	(cd servant && doctest src)
+	(cd servant && doctest test/Servant/LinksSpec.hs)
+
+doctest-servant-server :
+	(cd servant-server && doctest src)

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

cabal.project

@@ -15,8 +15,8 @@ packages:
   servant-pipes/
 
 -- servant GHCJS
-packages:
+-- packages:
-  servant-jsaddle/
+--   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

changelog.d/config

@@ -0,0 +1,2 @@
+organization: haskell-servant
+repository:   servant

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.
+
+}

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.
+
+}

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.
+
+}

changelog.d/jsaddle

@@ -0,0 +1,3 @@
+synopsis: Progress on servant-jsaddle
+packages: servant-jsaddle
+prs: #1216

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.
+
+}

changelog.d/pr1190

@@ -0,0 +1,7 @@
+synopsis: Add sponsorship button
+prs: #1190
+description: {
+
+[Well-Typed](https://www.well-typed.com/)
+
+}

changelog.d/pr1194

@@ -0,0 +1,3 @@
+synopsis: Prevent race-conditions in testing
+packages: servant-docs
+prs: #1194

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

changelog.d/pr1201

@@ -0,0 +1,3 @@
+synopsis: Remove unused extensions from cabal file
+packages: servant
+prs: #1201

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.
+
+}

changelog.d/pr1238

@@ -0,0 +1,3 @@
+synopsis: Redact the authorization header in Show and exceptions
+packages: servant-client
+prs: #1238

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.
+
+}

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).
+
+}

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

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.
+
+}

changelog.d/z-cookbook

@@ -0,0 +1,9 @@
+synopsis: New cookbook recipes
+prs: #1171 #1088 #1198
+
+description: {
+
+- [OIDC Recipe](#TODO)
+- [MySQL Recipe](#TODO)
+
+}

changelog.d/z-dependency-upgrades

@@ -0,0 +1,9 @@
+synopsis: Dependency upgrades
+prs:
+  #1173
+  #1181
+  #1183
+  #1188
+  #1224
+  #1245
+  #1257

changelog.d/z-documentation-updates

@@ -0,0 +1,8 @@
+synopsis: Documentation updates
+prs:
+  #1162
+  #1174
+  #1175
+  #1234
+  #1244
+  #1247

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:

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

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:
 

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

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

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:

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", "<REDACTED>")
+        redactSensitiveHeader h = h
 instance Bifunctor RequestF where bimap = bimapDefault
 instance Bifoldable RequestF where bifoldMap = bifoldMapDefault
 instance Bitraversable RequestF where

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

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

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

servant-client/src/Servant/Client.hs

@@ -9,6 +9,7 @@ module Servant.Client
   , runClientM
   , ClientEnv(..)
   , mkClientEnv
+  , defaultMakeClientRequest
   , hoistClient
   , module Servant.Client.Core.Reexport
   ) where

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
+  ClientEnv m burl cookieJar' createClientRequest <- ask
-  let clientRequest = requestToClientRequest burl req
+  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
+-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request'
-requestToClientRequest burl r = Client.defaultRequest
+--    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

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
+  ClientEnv m burl cookieJar' createClientRequest <- ask
-  let clientRequest = requestToClientRequest burl req
+  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

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

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)

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)
-

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

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
+-- 'combineAction' to mush two together taking the response from the very left.
--- types 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 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 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'.

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))
+    let md1 = markdown (docs (Proxy :: Proxy TestApi1))
-    tests md
+    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)
 

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

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

servant-jsaddle/CHANGELOG.md

@@ -1,4 +0,0 @@
-X.Y
-----
-
-Initial release

servant-jsaddle/LICENSE

@@ -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.

servant-jsaddle/README.md

@@ -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`.

servant-jsaddle/Setup.hs

@@ -1,2 +0,0 @@
-import           Distribution.Simple
-main = defaultMain

servant-jsaddle/servant-jsaddle.cabal

@@ -1,125 +0,0 @@
-name:               servant-jsaddle
-version:            0.16
-synopsis:
-  automatic derivation of querying functions for servant webservices for jsaddle
-
-description:
-  This library lets you automatically derive Haskell functions that
-  let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
-  .
-  See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
-  .
-  <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
-
-license:            BSD3
-license-file:       LICENSE
-author:             Servant Contributors
-maintainer:         haskell-servant-maintainers@googlegroups.com
-copyright:
-  2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors
-
-category:           Servant, Web
-build-type:         Simple
-cabal-version:      >=1.10
-tested-with:
-    GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5
-  , GHCJS ==8.4
-
-homepage:           http://haskell-servant.readthedocs.org/
-bug-reports:        http://github.com/haskell-servant/servant/issues
-extra-source-files:
-  CHANGELOG.md
-  README.md
-
-source-repository head
-  type:     git
-  location: http://github.com/haskell-servant/servant.git
-
-library
-  default-language: Haskell2010
-  hs-source-dirs:   src
-  ghc-options:      -Wall
-  exposed-modules:
-    Servant.Client.Internal.JSaddleXhrClient
-    Servant.Client.JSaddle
-
-  -- Bundled with GHC: Lower bound to not force re-installs
-  -- text and mtl are bundled starting with GHC-8.4
-  build-depends:
-      base          >=4.9      && <4.13
-    , bytestring    >=0.10.8.1 && <0.11
-    , containers    >=0.5.7.1  && <0.7
-    , mtl           >=2.2.2    && <2.3
-    , text          >=1.2.3.0  && <1.3
-    , transformers  >=0.5.2.0  && <0.6
-
-  if impl(ghcjs -any)
-    build-depends: ghcjs-base
-
-  -- Servant dependencies.
-  -- Strict dependency on `servant-client-core` as we re-export things.
-  build-depends:    servant-client-core >=0.16 && <0.16.1
-  build-depends:
-      base-compat         >=0.10.5  && <0.11
-    , case-insensitive    >=1.2.0.0 && <1.3
-    , exceptions          >=0.10.0  && <0.11
-    , ghcjs-dom
-    , http-media          >=0.7.1.3 && <0.9
-    , http-types          >=0.12.2  && <0.13
-    , jsaddle             >=0.9.6.0 && <0.10
-    , monad-control       >=1.0.2.3 && <1.1
-    , semigroupoids       >=5.3.1   && <5.4
-    , string-conversions  >=0.3     && <0.5
-    , transformers-base   >=0.4.4   && <0.5
-
-  if impl(ghc >=8.0)
-    ghc-options: -Wno-redundant-constraints
-
-test-suite spec
-  type:             exitcode-stdio-1.0
-  ghc-options:      -Wall
-  default-language: Haskell2010
-  hs-source-dirs:   test
-  main-is:          Spec.hs
-
-  if impl(ghcjs -any)
-    build-depends:
-        base
-      , servant-jsaddle
-
-  else
-    other-modules:      Servant.Client.JSaddleSpec
-
-    -- Dependencies inherited from the library. No need to specify bounds.
-    build-depends:
-        base
-      , bytestring
-      , containers
-      , exceptions
-      , ghcjs-dom
-      , http-media
-      , http-types
-      , jsaddle
-      , mtl
-      , process
-      , semigroupoids
-      , servant
-      , servant-client-core
-      , servant-jsaddle
-      , servant-server
-      , string-conversions
-      , text
-      , wai
-      , wai-cors
-      , wai-extra
-      , warp
-      , websockets
-
-    -- Additonal dependencies
-    build-depends:
-        aeson
-      , hspec
-      , jsaddle-warp
-      , QuickCheck
-
-    build-tool-depends: hspec-discover:hspec-discover >=2.4.4 && <2.5

servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs

@@ -1,311 +0,0 @@
-{-# LANGUAGE CPP                        #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE OverloadedStrings          #-}
-{-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE UndecidableInstances       #-}
-{-# LANGUAGE ViewPatterns               #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-
-module Servant.Client.Internal.JSaddleXhrClient where
-
-import           Prelude ()
-import           Prelude.Compat
-
-import           Control.Concurrent
-                 (MVar, newEmptyMVar, takeMVar, tryPutMVar)
-import           Control.Exception
-                 (Exception, toException)
-import           Control.Monad
-                 (forM_, unless, void)
-import           Control.Monad.Catch
-                 (MonadCatch, MonadThrow, catch)
-import           Control.Monad.Error.Class
-                 (MonadError (..))
-import           Control.Monad.IO.Class
-                 (MonadIO (..))
-import           Control.Monad.Reader
-                 (MonadReader, ReaderT, asks, runReaderT)
-import           Control.Monad.Trans.Except
-                 (ExceptT, runExceptT)
-import           Data.Bifunctor
-                 (bimap, first, second)
-import           Data.ByteString.Builder
-                 (toLazyByteString)
-import qualified Data.ByteString.Char8             as BS
-import qualified Data.ByteString.Lazy              as BSL
-import qualified Data.ByteString.Lazy              as L
-import           Data.CaseInsensitive
-                 (mk, original)
-import           Data.Char
-                 (isSpace)
-import           Data.Foldable
-                 (toList)
-import           Data.Functor.Alt
-                 (Alt (..))
-import           Data.Proxy
-                 (Proxy (..))
-import qualified Data.Sequence                     as Seq
-import           Data.String.Conversions
-                 (cs)
-import qualified Data.Text.Encoding                as T
-import qualified Data.Text.Encoding.Error          as T
-import           GHC.Generics
-import qualified GHCJS.Buffer                      as Buffer
-import qualified GHCJS.DOM
-import qualified GHCJS.DOM.EventM                  as JSDOM
-import qualified GHCJS.DOM.Location                as Location
-import           GHCJS.DOM.Types
-                 (DOM, DOMContext, askDOM, runDOM)
-import qualified GHCJS.DOM.Types                   as JS
-import qualified GHCJS.DOM.Window                  as Window
-import qualified GHCJS.DOM.XMLHttpRequest          as JS
-import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer
-import qualified Language.Javascript.JSaddle.Types as JSaddle
-import           Network.HTTP.Media
-                 (renderHeader)
-import           Network.HTTP.Types
-                 (ResponseHeaders, http11, mkStatus, renderQuery, statusCode)
-import           System.IO
-                 (hPutStrLn, stderr)
-
-import           Servant.Client.Core
-
--- Note: assuming encoding UTF-8
-
-data ClientEnv
-   = ClientEnv
-   { baseUrl :: BaseUrl
-     -- | Modify the XMLHttpRequest at will, right before sending.
-   , fixUpXhr :: JS.XMLHttpRequest -> DOM ()
-   }
-
-data JSaddleConnectionError = JSaddleConnectionError
-  deriving (Eq, Show)
-
-instance Exception JSaddleConnectionError
-
--- | Default 'ClientEnv'
-mkClientEnv :: BaseUrl -> ClientEnv
-mkClientEnv burl = ClientEnv burl (const (pure ()))
-
-instance Show ClientEnv where
-  showsPrec prec (ClientEnv burl _) =
-    showParen (prec >= 11)
-      ( showString "ClientEnv {"
-      . showString "baseUrl = "
-      . showsPrec 0 burl
-      . showString ", fixUpXhr = <function>"
-      . showString "}"
-      )
-
-client :: HasClient ClientM api => Proxy api -> Client ClientM api
-client api = api `clientIn` (Proxy :: Proxy ClientM)
-
-newtype ClientM a = ClientM
-  { fromClientM :: ReaderT ClientEnv (ExceptT ClientError DOM) a }
-  deriving ( Functor, Applicative, Monad, MonadIO, Generic
-           , MonadReader ClientEnv, MonadError ClientError)
-deriving instance MonadThrow DOM => MonadThrow ClientM
-deriving instance MonadCatch DOM => MonadCatch ClientM
-
--- | Try clients in order, last error is preserved.
-instance Alt ClientM where
-  a <!> b = a `catchError` const b
-
-instance RunClient ClientM where
-  throwClientError = throwError
-  runRequest r = do
-    d <- ClientM askDOM
-    performRequest d r
-
-runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a)
-runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm
-
-runClientM' :: ClientM a -> DOM (Either ClientError a)
-runClientM' m = do
-    burl <- getDefaultBaseUrl
-    runClientM m (mkClientEnv burl)
-
-getDefaultBaseUrl :: DOM BaseUrl
-getDefaultBaseUrl = do
-    win <- GHCJS.DOM.currentWindow >>= \mw -> case mw of
-      Just x -> pure x
-      Nothing -> fail "Can not determine default base url without window."
-    curLoc <- Window.getLocation win
-
-    protocolStr  <- Location.getProtocol curLoc
-    portStr      <- Location.getPort     curLoc
-    hostname     <- Location.getHostname curLoc
-
-    let protocol
-          | (protocolStr :: JS.JSString) == "https:"
-                        = Https
-          | otherwise   = Http
-
-        port :: Int
-        port | null portStr = case protocol of
-                 Http  ->  80
-                 Https -> 443
-             | otherwise = read portStr
-
-    pure (BaseUrl protocol hostname port "")
-
-performRequest :: DOMContext -> Request -> ClientM Response
-performRequest domc req = do
-  xhr <- JS.newXMLHttpRequest `runDOM` domc
-  burl <- asks baseUrl
-  fixUp <- asks fixUpXhr
-  performXhr xhr burl req fixUp `runDOM` domc
-  resp <- toResponse domc xhr
-
-  let status = statusCode (responseStatusCode resp)
-  unless (status >= 200 && status < 300) $
-        throwError $ mkFailureResponse burl req resp
-
-  pure resp
-
-
--- * performing requests
--- Performs the xhr and blocks until the response was received
-performXhr :: JS.XMLHttpRequest -> BaseUrl -> Request -> (JS.XMLHttpRequest -> DOM ()) -> DOM ()
-performXhr xhr burl request fixUp = do
-
-    let username, password :: Maybe JS.JSString
-        username = Nothing; password = Nothing
-
-    JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password
-    setHeaders xhr request
-    fixUp xhr
-
-    waiter <- liftIO $ newEmptyMVar
-
-    cleanup <- JSDOM.on xhr JS.readyStateChange $ do
-      state <- JS.getReadyState xhr
-      case state of
-        -- onReadyStateChange's callback can fire state 4
-        -- (which means "request finished and response is ready")
-        -- multiple times. By using tryPutMVar, only the first time
-        -- state 4 is fired will cause an MVar to be put. Subsequent
-        -- fires are ignored.
-        4 -> void $ liftIO $ tryPutMVar waiter ()
-        _ -> return ()
-
-    sendXhr xhr (toBody request) `catch` handleXHRError waiter -- We handle any errors in `toResponse`.
-
-    liftIO $ takeMVar waiter
-
-    cleanup
-
-  where
-
-    handleXHRError :: MVar () -> JS.XHRError -> DOM ()
-    handleXHRError waiter e = do
-      liftIO $ hPutStrLn stderr $ "servant-client-jsaddle: exception in `sendXhr` (should get handled in response handling): " <> show e
-      void $ liftIO $ tryPutMVar waiter ()
-
-
-toUrl :: BaseUrl -> Request -> JS.JSString
-toUrl burl request =
-  let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $
-              requestPath request
-      queryS =
-          JS.toJSString $ decodeUtf8Lenient $
-          renderQuery True $
-          toList $
-          requestQueryString request
-  in JS.toJSString (showBaseUrl burl) <> pathS <> queryS :: JS.JSString
-
-setHeaders :: JS.XMLHttpRequest -> Request -> DOM ()
-setHeaders xhr request = do
-  forM_ (toList $ requestAccept request) $ \mediaType -> -- FIXME review
-    JS.setRequestHeader
-      xhr
-      ("Accept" :: JS.JSString)
-      (decodeUtf8Lenient $ renderHeader mediaType)
-
-  forM_ (requestBody request) $ \(_, mediaType) ->
-    JS.setRequestHeader
-      xhr
-      ("Content-Type" :: JS.JSString)
-      (decodeUtf8Lenient $ renderHeader mediaType)
-
-  forM_ (toList $ requestHeaders request) $ \(key, value) ->
-    JS.setRequestHeader xhr (decodeUtf8Lenient $ original key) (decodeUtf8Lenient value)
-
--- ArrayBufferView is a type that only exists in the spec and covers many concrete types.
-castMutableArrayBufferToArrayBufferView :: ArrayBuffer.MutableArrayBuffer -> DOM JS.ArrayBufferView
-castMutableArrayBufferToArrayBufferView x = JS.liftJSM $ do
-  JS.fromJSValUnchecked $ JS.pToJSVal x
-
-mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError
-mkFailureResponse burl request =
-    FailureResponse (bimap (const ()) f request)
-  where
-    f b = (burl, BSL.toStrict $ toLazyByteString b)
-
-sendXhr :: JS.XMLHttpRequest -> Maybe L.ByteString -> DOM ()
-sendXhr xhr Nothing = JS.send xhr
-sendXhr xhr (Just body) = do
-  -- Reason for copy: hopefully offset will be 0 and length b == len
-  -- FIXME: use a typed array constructor that accepts offset and length and skip the copy
-  (b, _offset, _len) <- JSaddle.ghcjsPure $ Buffer.fromByteString $ BS.copy $ L.toStrict body
-  b' <- Buffer.thaw b
-  b'' <- JSaddle.ghcjsPure $ Buffer.getArrayBuffer b'
-  JS.sendArrayBuffer xhr =<< castMutableArrayBufferToArrayBufferView b''
-
-toBody :: Request -> Maybe L.ByteString
-toBody request = case requestBody request of
-  Nothing -> Nothing
-  Just (RequestBodyLBS "", _) -> Nothing
-  Just (RequestBodyLBS x, _) -> Just x
-  Just (RequestBodyBS "", _) -> Nothing
-  Just (RequestBodyBS x, _)  -> Just $ L.fromStrict x
-  Just (RequestBodySource _, _) -> error "RequestBodySource isn't supported"
-
--- * inspecting the xhr response
-
--- This function is only supposed to handle 'ConnectionError's. Other
--- 'ClientError's are created in Servant.Client.Req.
-toResponse :: DOMContext -> JS.XMLHttpRequest -> ClientM Response
-toResponse domc xhr = do
-  let inDom :: DOM a -> ClientM a
-      inDom = flip runDOM domc
-  status <- inDom $ JS.getStatus xhr
-  case status of
-    0 -> throwError $ ConnectionError $ toException JSaddleConnectionError
-    _ -> inDom $ do
-      statusText <- BS.pack <$> JS.getStatusText xhr
-      headers <- parseHeaders <$> JS.getAllResponseHeaders xhr
-      responseText <- maybe "" (L.fromStrict . BS.pack) <$> JS.getResponseText xhr -- FIXME: Text/Binary? Performance? Test?
-      pure Response
-        { responseStatusCode  = mkStatus (fromIntegral status) statusText
-        , responseBody        = responseText
-        , responseHeaders     = Seq.fromList headers
-        , responseHttpVersion = http11 -- this is made up
-        }
-
-parseHeaders :: String -> ResponseHeaders
-parseHeaders s =
-  (first mk . first strip . second strip . parseHeader) <$>
-  splitOn "\r\n" (cs s)
-  where
-    parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
-    parseHeader h = case BS.breakSubstring ":" (cs h) of
-      (key, BS.drop 1 -> value) -> (key, value)
-
-    splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
-    splitOn separator input = case BS.breakSubstring separator input of
-      (prefix, "") -> [prefix]
-      (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest)
-
-    strip :: BS.ByteString -> BS.ByteString
-    strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse
-
-decodeUtf8Lenient :: BS.ByteString -> JS.JSString
-decodeUtf8Lenient = JS.toJSString . T.decodeUtf8With T.lenientDecode

servant-jsaddle/src/Servant/Client/JSaddle.hs

@@ -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

servant-jsaddle/test/Servant/Client/JSaddleSpec.hs

@@ -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

servant-jsaddle/test/Spec.hs

@@ -1,8 +0,0 @@
-{-# LANGUAGE CPP #-}
-#ifdef __GHCJS__
-module Main (main) where
-main :: IO ()
-main = return ()
-#else
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
-#endif

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

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

servant-server/Setup.hs

@@ -1,33 +1,2 @@
-{-# LANGUAGE CPP #-}
+import           Distribution.Simple
-{-# OPTIONS_GHC -Wall #-}
-module Main (main) where
-
-#ifndef MIN_VERSION_cabal_doctest
-#define MIN_VERSION_cabal_doctest(x,y,z) 0
-#endif
-
-#if MIN_VERSION_cabal_doctest(1,0,0)
-
-import Distribution.Extra.Doctest ( defaultMainWithDoctests )
-main :: IO ()
-main = defaultMainWithDoctests "doctests"
-
-#else
-
-#ifdef MIN_VERSION_Cabal
--- If the macro is defined, we have new cabal-install,
--- but for some reason we don't have cabal-doctest in package-db
---
--- Probably we are running cabal sdist, when otherwise using new-build
--- workflow
-#warning You are configuring this package without cabal-doctest installed. \
-         The doctests test-suite will not work as a result. \
-         To fix this, install cabal-doctest before configuring.
-#endif
-
-import Distribution.Simple
-
-main :: IO ()
 main = defaultMain
-
-#endif

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

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
+                 . queryToQueryText
-                 . rawQueryString
+                 . 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

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 (..),
+                 (MonadBaseControl (..))
-                 defaultLiftBaseWith, defaultRestoreM)
 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

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,
+                 (Application, Middleware, Request, pathInfo, queryString,
-                 requestHeaders, responseLBS)
+                 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,
+                 BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
-                 EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..),
+                 Delete, EmptyAPI, Get, Header, Headers, HttpVersion,
-                 JSON, NoContent (..), NoFraming, OctetStream, Patch,
+                 IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
-                 PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, QueryParamForm, Raw,
+                 NoFraming, OctetStream, Patch, PlainText, Post, Put,
-                 RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb,
+                 QueryFlag, QueryParam, QueryParams, QueryParamForm, Raw, RemoteHost, ReqBody,
-                 NoContentVerb, addHeader)
+                 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
+        flip runSession (serve queryParamApi qpServer) $ do
-          let params1 = "?name=bob"
+          response1 <- mkRequest "?name=bob" []
-          response1 <- Network.Wai.Test.request defaultRequest{
+          liftIO $ decode' (simpleBody response1) `shouldBe` Just alice
-            rawQueryString = params1,
+            { name = "bob"
-            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
             }
 
+      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
+        flip runSession (serve queryParamApi qpServer) $ do
-        let params = "?age=foo"
+        response <- mkRequest "?age=foo" ["param"]
-        response <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params,
-            queryString = parseQuery params,
-            pathInfo = ["param"]
-           }
         liftIO $ statusCode (simpleStatus response) `shouldBe` 400
         return ()
 
       it "parses multiple query parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
+        flip runSession (serve queryParamApi qpServer) $ do
-        let params = "?ages=10&ages=22"
+        response <- mkRequest "?ages=10&ages=22" ["multiparam"]
-        response <- Network.Wai.Test.request defaultRequest{
+        liftIO $ decode' (simpleBody response) `shouldBe` Just alice
-            rawQueryString = params,
+          { age = 32
-            queryString = parseQuery params,
+          }
-            pathInfo = ["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
+        flip runSession (serve queryParamApi qpServer) $ do
-        let params = "?ages=2&ages=foo"
+        response <- mkRequest "?ages=2&ages=foo" ["multiparam"]
-        response <- Network.Wai.Test.request defaultRequest{
-            rawQueryString = params,
-            queryString = parseQuery params,
-            pathInfo = ["multiparam"]
-           }
         liftIO $ statusCode (simpleStatus response) `shouldBe` 400
         return ()
 
-
       it "allows retrieving value-less GET parameters" $
-        (flip runSession) (serve queryParamApi qpServer) $ do
+        flip runSession (serve queryParamApi qpServer) $ do
-          let params3 = "?capitalize"
+          response3 <- mkRequest "?capitalize" ["b"]
-          response3 <- Network.Wai.Test.request defaultRequest{
+          liftIO $ decode' (simpleBody response3) `shouldBe` Just alice
-            rawQueryString = params3,
+            { name = "ALICE"
-            queryString = parseQuery params3,
+            }
-            pathInfo = ["b"]
-           }
-          liftIO $
-            decode' (simpleBody response3) `shouldBe` Just alice{
-              name = "ALICE"
-             }
 
-          let params3' = "?capitalize="
+          response3' <- mkRequest "?capitalize=" ["b"]
-          response3' <- Network.Wai.Test.request defaultRequest{
+          liftIO $ decode' (simpleBody response3') `shouldBe` Just alice
-            rawQueryString = params3',
+            { name = "ALICE"
-            queryString = parseQuery params3',
+            }
-            pathInfo = ["b"]
-           }
-          liftIO $
-            decode' (simpleBody response3') `shouldBe` Just alice{
-              name = "ALICE"
-             }
 
-          let params3'' = "?unknown="
+          response3'' <- mkRequest "?unknown=" ["b"]
-          response3'' <- Network.Wai.Test.request defaultRequest{
+          liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice
-            rawQueryString = params3'',
+            { name = "Alice"
-            queryString = parseQuery params3'',
+            }
-            pathInfo = ["b"]
+
-           }
+      describe "Uses queryString instead of rawQueryString" $ do
-          liftIO $
+        -- test query parameters rewriter
-            decode' (simpleBody response3'') `shouldBe` Just alice{
+        let queryRewriter :: Middleware
-              name = "Alice"
+            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"]
          }

servant-server/test/doctests.hs

@@ -1,27 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module      :  Main (doctests)
--- Copyright   :  (C) 2012-14 Edward Kmett
--- License     :  BSD-style (see the file LICENSE)
--- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
---
--- This module provides doctests for a project based on the actual versions
--- of the packages it was built with. It requires a corresponding Setup.lhs
--- to be added to the project
------------------------------------------------------------------------------
-module Main where
-
-import           Build_doctests
-                 (flags, module_sources, pkgs)
-import           Data.Foldable
-                 (traverse_)
-import           Test.DocTest
-
-main :: IO ()
-main = do
-    traverse_ putStrLn args
-    doctest args
-  where
-    args = flags ++ pkgs ++ module_sources

servant/Setup.hs

@@ -1,33 +1,2 @@
-{-# LANGUAGE CPP #-}
+import           Distribution.Simple
-{-# OPTIONS_GHC -Wall #-}
-module Main (main) where
-
-#ifndef MIN_VERSION_cabal_doctest
-#define MIN_VERSION_cabal_doctest(x,y,z) 0
-#endif
-
-#if MIN_VERSION_cabal_doctest(1,0,0)
-
-import Distribution.Extra.Doctest ( defaultMainWithDoctests )
-main :: IO ()
-main = defaultMainWithDoctests "doctests"
-
-#else
-
-#ifdef MIN_VERSION_Cabal
--- If the macro is defined, we have new cabal-install,
--- but for some reason we don't have cabal-doctest in package-db
---
--- Probably we are running cabal sdist, when otherwise using new-build
--- workflow
-#warning You are configuring this package without cabal-doctest installed. \
-         The doctests test-suite will not work as a result. \
-         To fix this, install cabal-doctest before configuring.
-#endif
-
-import Distribution.Simple
-
-main :: IO ()
 main = defaultMain
-
-#endif

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

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

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 <https://hackage.haskell.org/package/servant-server/docs/Servant-Utils-StaticFiles.html#v:serveDirectory serveDirectory> to serve
+-- this can also be used with functions from
--- static files stored in a particular directory on your filesystem
+-- <https://hackage.haskell.org/package/servant-server/docs/Servant-Server-StaticFiles.html Servant.Server.StaticFiles>
+-- to serve static files stored in a particular directory on your filesystem
 data Raw deriving Typeable

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 = ()

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

servant/test/doctests.hs

@@ -1,27 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module      :  Main (doctests)
--- Copyright   :  (C) 2012-14 Edward Kmett
--- License     :  BSD-style (see the file LICENSE)
--- Maintainer  :  Edward Kmett <ekmett@gmail.com>
--- Stability   :  provisional
--- Portability :  portable
---
--- This module provides doctests for a project based on the actual versions
--- of the packages it was built with. It requires a corresponding Setup.lhs
--- to be added to the project
------------------------------------------------------------------------------
-module Main where
-
-import           Build_doctests
-                 (flags, module_sources, pkgs)
-import           Data.Foldable
-                 (traverse_)
-import           Test.DocTest
-
-main :: IO ()
-main = do
-    traverse_ putStrLn args
-    doctest args
-  where
-    args = flags ++ pkgs ++ module_sources

stack.yaml

@@ -1,10 +1,10 @@
-# Let's try to keep resolver at the first day of the month
+resolver: lts-14.17
-resolver: nightly-2018-09-28 # Last nightly with GHC-8.4.3
 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
+- hspec-wai-0.10.1
-- 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