diff --git a/.github/FUNDING.yml b/.github/FUNDING.yml index 3fa9ad6f..784ce6fc 100644 --- a/.github/FUNDING.yml +++ b/.github/FUNDING.yml @@ -1,6 +1,6 @@ # These are supported funding model platforms -github: # Replace with up to 4 GitHub Sponsors-enabled usernames e.g., [user1, user2] +github: [arianvp] patreon: # Replace with a single Patreon username open_collective: # Replace with a single Open Collective username ko_fi: # Replace with a single Ko-fi username diff --git a/.github/run-ghcjs-tests.sh b/.github/run-ghcjs-tests.sh new file mode 100755 index 00000000..19e0d9b7 --- /dev/null +++ b/.github/run-ghcjs-tests.sh @@ -0,0 +1,14 @@ +#!/usr/bin/env bash +# +# cabal v2-test does not work with GHCJS +# See: https://github.com/haskell/cabal/issues/6175 +# +# This invokes cabal-plan to figure out test binaries, and invokes them with node. + +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 "$testpkg" && node "$testexe".jsexe/all.js) +done diff --git a/.github/workflows/master.yml b/.github/workflows/master.yml new file mode 100644 index 00000000..04b94995 --- /dev/null +++ b/.github/workflows/master.yml @@ -0,0 +1,159 @@ +name: CI + +# Trigger the workflow on push or pull request, but only for the master branch +on: + pull_request: + push: + branches: [master] + +jobs: + cabal: + name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest] + cabal: ["3.4"] + ghc: + - "8.6.5" + - "8.8.4" + - "8.10.7" + - "9.0.1" + + steps: + - uses: actions/checkout@v2 + + - uses: haskell/actions/setup@v1 + id: setup-haskell-cabal + name: Setup Haskell + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Freeze + run: | + cabal configure --enable-tests --enable-benchmarks --test-show-details=direct + cabal freeze + + - uses: actions/cache@v2.1.3 + name: Cache ~/.cabal/store and dist-newstyle + with: + path: | + ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + dist-newstyle + key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} + restore-keys: | + ${{ runner.os }}-${{ matrix.ghc }}- + + - name: Configure + run: | + # Using separate store-dir because default one already has 'ghc-paths' package installed + # with hardcoded path to ghcup's GHC path (which it was built with). This leads to failure in + # doctest, as it tries to invoke that GHC, and it doesn't exist here. + cabal --store-dir /tmp/cabal-store install --ignore-project -j2 doctest --constraint='doctest ^>=0.18' + + - name: Build + run: | + cabal build all + + - name: Test + run: | + cabal test all + + - name: Run doctests + # doctests are broken on GHC 9 due to compiler bug: + # https://gitlab.haskell.org/ghc/ghc/-/issues/19460 + continue-on-error: ${{ matrix.ghc == '9.0.1' }} + run: | + # Necessary for doctest to be found in $PATH + export PATH="$HOME/.cabal/bin:$PATH" + + # Filter out base-compat-batteries from .ghc.environment.*, as its modules + # conflict with those of base-compat. + # + # FIXME: This is an ugly hack. Ultimately, we'll want to use cabal-doctest + # (or cabal v2-doctest, if it ever lands) to provide a clean GHC environment. + # This might allow running doctests in GHCJS build as well. + perl -i -e 'while () { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.* + + (cd servant && doctest src) + (cd servant-client && doctest src) + (cd servant-client-core && doctest src) + (cd servant-http-streams && doctest src) + (cd servant-docs && doctest src) + (cd servant-foreign && doctest src) + (cd servant-server && doctest src) + (cd servant-machines && doctest src) + (cd servant-conduit && doctest src) + (cd servant-pipes && doctest src) + + stack: + name: stack / ghc ${{ matrix.ghc }} + runs-on: ubuntu-latest + strategy: + matrix: + stack: ["2.7.3"] + ghc: ["8.10.4"] + + steps: + - uses: actions/checkout@v2 + + - uses: haskell/actions/setup@v1 + name: Setup Haskell Stack + with: + ghc-version: ${{ matrix.ghc }} + stack-version: ${{ matrix.stack }} + + - uses: actions/cache@v2.1.3 + name: Cache ~/.stack + with: + path: ~/.stack + key: ${{ runner.os }}-${{ matrix.ghc }}-stack + + - name: Install dependencies + run: | + stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks --only-dependencies + + - name: Build + run: | + stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks + + - name: Test + run: | + stack test --system-ghc + + ghcjs: + name: ubuntu-latest / ghcjs 8.6 + runs-on: "ubuntu-latest" + + steps: + - uses: actions/checkout@v2 + - uses: cachix/install-nix-action@v13 + with: + extra_nix_config: | + trusted-public-keys = ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=1aba6f367982bd6dd78ec2fda75ab246a62d32c5 cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= + substituters = https://nixcache.reflex-frp.org https://cache.nixos.org/ + - name: Setup + run: | + # Override cabal.project with the lightweight GHCJS one + cp cabal.ghcjs.project cabal.project + cat cabal.project + nix-shell ghcjs.nix --run "cabal v2-update && cabal v2-freeze" + + - uses: actions/cache@v2.1.3 + name: Cache ~/.cabal/store and dist-newstyle + with: + path: | + ~/.cabal/store + dist-newstyle + key: ${{ runner.os }}-ghcjs8.6-${{ hashFiles('cabal.project.freeze') }} + restore-keys: | + ${{ runner.os }}-ghcjs8.6- + + - name: Build + run: | + nix-shell ghcjs.nix --run "cabal v2-build --ghcjs --enable-tests --enable-benchmarks all" + + - name: Tests + run: | + nix-shell ghcjs.nix --run ".github/run-ghcjs-tests.sh" diff --git a/.gitignore b/.gitignore index baf818e7..6cec8e9d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ **/*/dist +*~ dist-* .ghc.environment.* /bin @@ -29,6 +30,10 @@ doc/_build doc/venv doc/tutorial/static/api.js doc/tutorial/static/jq.js +shell.nix + +# nix +result* # local versions of things servant-multipart diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 4f839a90..00000000 --- a/.travis.yml +++ /dev/null @@ -1,322 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--config=cabal.haskell-ci' '--output=.travis.yml' 'cabal.project' -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.9.20200110 -# -version: ~> 1.0 -language: c -os: linux -dist: bionic -git: - # whether to recursively clone submodules - submodules: false -branches: - only: - - master -addons: - google: stable -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' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.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 -jobs: - include: - - compiler: ghcjs-8.4 - 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":[{"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":[{"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":[{"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":[{"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":[{"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 - GHCJS=true; - else - GHCJS=false; - 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 PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - 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" - - set -o pipefail -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - node --version - - echo $GHCJS - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - echo " 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 - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - 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 $WITHCOMPILER -j2 doctest --constraint='doctest ==0.16.2.*') ; fi - - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe') ; fi - - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover) ; fi - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: servant" >> cabal.project - if ! $GHCJS ; then echo "packages: servant-client" >> cabal.project ; fi - echo "packages: servant-client-core" >> cabal.project - if ! $GHCJS ; then echo "packages: servant-http-streams" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: servant-docs" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: servant-foreign" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: servant-server" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: doc/tutorial" >> cabal.project ; fi - 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 && [ $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 - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/db-postgres-pool" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/file-upload" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/generic" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/pagination" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/testing" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/structuring-apis" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-custom-monad" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/using-free-client" >> cabal.project ; fi - - | - 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 - echo "allow-newer: sqlite-simple-0.4.16.0:semigroups" >> cabal.project - echo "allow-newer: direct-sqlite-2.3.24:semigroups" >> cabal.project - echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project - 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-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 - - if [ -f "servant-client/configure.ac" ]; then (cd "servant-client" && autoreconf -i); fi - - if [ -f "servant-client-core/configure.ac" ]; then (cd "servant-client-core" && autoreconf -i); fi - - if [ -f "servant-http-streams/configure.ac" ]; then (cd "servant-http-streams" && autoreconf -i); fi - - if [ -f "servant-docs/configure.ac" ]; then (cd "servant-docs" && autoreconf -i); fi - - if [ -f "servant-foreign/configure.ac" ]; then (cd "servant-foreign" && autoreconf -i); fi - - if [ -f "servant-server/configure.ac" ]; then (cd "servant-server" && autoreconf -i); fi - - if [ -f "doc/tutorial/configure.ac" ]; then (cd "doc/tutorial" && autoreconf -i); fi - - 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 "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 - - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then (cd "doc/cookbook/db-postgres-pool" && autoreconf -i); fi - - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then (cd "doc/cookbook/file-upload" && autoreconf -i); fi - - if [ -f "doc/cookbook/generic/configure.ac" ]; then (cd "doc/cookbook/generic" && autoreconf -i); fi - - if [ -f "doc/cookbook/pagination/configure.ac" ]; then (cd "doc/cookbook/pagination" && autoreconf -i); fi - - if [ -f "doc/cookbook/testing/configure.ac" ]; then (cd "doc/cookbook/testing" && autoreconf -i); fi - - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi - - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi - - if [ -f "doc/cookbook/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi - - ${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 - - echo -en 'travis_fold:end:sdist\\r' - # Unpacking... - - echo 'Unpacking...' && echo -en 'travis_fold:start:unpack\\r' - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_servant="$(find . -maxdepth 1 -type d -regex '.*/servant-[0-9.]*')" - - PKGDIR_servant_client="$(find . -maxdepth 1 -type d -regex '.*/servant-client-[0-9.]*')" - - PKGDIR_servant_client_core="$(find . -maxdepth 1 -type d -regex '.*/servant-client-core-[0-9.]*')" - - PKGDIR_servant_http_streams="$(find . -maxdepth 1 -type d -regex '.*/servant-http-streams-[0-9.]*')" - - PKGDIR_servant_docs="$(find . -maxdepth 1 -type d -regex '.*/servant-docs-[0-9.]*')" - - PKGDIR_servant_foreign="$(find . -maxdepth 1 -type d -regex '.*/servant-foreign-[0-9.]*')" - - PKGDIR_servant_server="$(find . -maxdepth 1 -type d -regex '.*/servant-server-[0-9.]*')" - - PKGDIR_tutorial="$(find . -maxdepth 1 -type d -regex '.*/tutorial-[0-9.]*')" - - 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_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.]*')" - - PKGDIR_cookbook_db_postgres_pool="$(find . -maxdepth 1 -type d -regex '.*/cookbook-db-postgres-pool-[0-9.]*')" - - PKGDIR_cookbook_file_upload="$(find . -maxdepth 1 -type d -regex '.*/cookbook-file-upload-[0-9.]*')" - - PKGDIR_cookbook_generic="$(find . -maxdepth 1 -type d -regex '.*/cookbook-generic-[0-9.]*')" - - PKGDIR_cookbook_pagination="$(find . -maxdepth 1 -type d -regex '.*/cookbook-pagination-[0-9.]*')" - - PKGDIR_cookbook_testing="$(find . -maxdepth 1 -type d -regex '.*/cookbook-testing-[0-9.]*')" - - PKGDIR_cookbook_structuring_apis="$(find . -maxdepth 1 -type d -regex '.*/cookbook-structuring-apis-[0-9.]*')" - - PKGDIR_cookbook_using_custom_monad="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-custom-monad-[0-9.]*')" - - PKGDIR_cookbook_using_free_client="$(find . -maxdepth 1 -type d -regex '.*/cookbook-using-free-client-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_servant}" >> cabal.project - if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_client}" >> cabal.project ; fi - echo "packages: ${PKGDIR_servant_client_core}" >> cabal.project - if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_http_streams}" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_docs}" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_foreign}" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_server}" >> cabal.project ; fi - if ! $GHCJS ; then echo "packages: ${PKGDIR_tutorial}" >> cabal.project ; fi - 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 && [ $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 - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_db_postgres_pool}" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_file_upload}" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_generic}" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_pagination}" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_testing}" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_structuring_apis}" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_custom_monad}" >> cabal.project ; fi - if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_using_free_client}" >> cabal.project ; fi - - | - 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 - echo "allow-newer: sqlite-simple-0.4.16.0:semigroups" >> cabal.project - echo "allow-newer: direct-sqlite-2.3.24:semigroups" >> cabal.project - echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project - 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-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 - - | - pkgdir() { - case $1 in - servant) echo ${PKGDIR_servant} ;; - servant-client) echo ${PKGDIR_servant_client} ;; - servant-client-core) echo ${PKGDIR_servant_client_core} ;; - servant-http-streams) echo ${PKGDIR_servant_http_streams} ;; - servant-docs) echo ${PKGDIR_servant_docs} ;; - servant-foreign) echo ${PKGDIR_servant_foreign} ;; - servant-server) echo ${PKGDIR_servant_server} ;; - tutorial) echo ${PKGDIR_tutorial} ;; - servant-machines) echo ${PKGDIR_servant_machines} ;; - servant-conduit) echo ${PKGDIR_servant_conduit} ;; - servant-pipes) echo ${PKGDIR_servant_pipes} ;; - cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;; - cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;; - cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;; - cookbook-db-postgres-pool) echo ${PKGDIR_cookbook_db_postgres_pool} ;; - cookbook-file-upload) echo ${PKGDIR_cookbook_file_upload} ;; - cookbook-generic) echo ${PKGDIR_cookbook_generic} ;; - cookbook-pagination) echo ${PKGDIR_cookbook_pagination} ;; - cookbook-testing) echo ${PKGDIR_cookbook_testing} ;; - cookbook-structuring-apis) echo ${PKGDIR_cookbook_structuring_apis} ;; - cookbook-using-custom-monad) echo ${PKGDIR_cookbook_using_custom_monad} ;; - cookbook-using-free-client) echo ${PKGDIR_cookbook_using_free_client} ;; - esac - } - - echo -en 'travis_fold:end:unpack\\r' - # 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 - - echo -en 'travis_fold:end:build-everything\\r' - # Testing... - - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all ; fi - - if $GHCJS ; then cabal-plan list-bins '*:test:*' | while read -r line; do testpkg=$(echo "$line" | perl -pe 's/:.*//'); testexe=$(echo "$line" | awk '{ print $2 }'); echo "testing $textexe in package $textpkg"; (cd "$(pkgdir $testpkg)" && nodejs "$testexe".jsexe/all.js); done ; fi - # Doctest... - - echo 'Doctest...' && echo -en 'travis_fold:start:doctest\\r' - - perl -i -e 'while () { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.* - - if ! $GHCJS ; then (cd ${PKGDIR_servant} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_client} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_client_core} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_http_streams} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_docs} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_foreign} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_server} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_machines} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_conduit} && doctest src) ; fi - - if ! $GHCJS ; then (cd ${PKGDIR_servant_pipes} && doctest src) ; fi - - echo -en 'travis_fold:end:doctest\\r' - # haddock... - - echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r' - - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi - - echo -en 'travis_fold:end:haddock\\r' - -# REGENDATA ("0.9.20200110",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]) -# EOF diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 46eb65f7..855e5a38 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -103,7 +103,7 @@ the `news` label if you make a new package so we can know about it! ## Release policy -We are currently moving to a more aggresive release policy, so that you can get +We are currently moving to a more aggressive release policy, so that you can get what you contribute from Hackage fairly soon. However, note that prior to major releases it may take some time in between releases. diff --git a/Makefile b/Makefile deleted file mode 100644 index 2caf4c05..00000000 --- a/Makefile +++ /dev/null @@ -1,32 +0,0 @@ -# With common maintenance tasks - -HC ?= ghc-8.4.4 - -all : - @echo "Don't try to make all at once!" - -really-all : - $(MAKE) build-ghc - $(MAKE) build-ghc HC=ghc-8.0.2 - $(MAKE) build-ghc HC=ghc-8.2.2 - $(MAKE) build-ghc HC=ghc-8.6.5 - $(MAKE) build-ghcjs - -build-ghc : - cabal v2-build -w $(HC) all - -build-ghcjs : - cabal v2-build --builddir=dist-newstyle-ghcjs --project-file=cabal.ghcjs.project all - -packdeps : - packdeps */*.cabal - -doctest : doctest-servant doctest-servant-server - perl -i -e 'while () { print unless /package-id\s+base-compat-\d+(\.\d+)*/; }' .ghc.environment.* - -doctest-servant : - (cd servant && doctest src) - (cd servant && doctest test/Servant/LinksSpec.hs) - -doctest-servant-server : - (cd servant-server && doctest src) diff --git a/README.md b/README.md index 54a0e423..e4a0316b 100644 --- a/README.md +++ b/README.md @@ -9,11 +9,11 @@ introduces the core features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples. -The central documentation can be found [here](http://docs.servant.dev/). +The core documentation can be found [here](http://docs.servant.dev/). Other blog posts, videos and slides can be found on the [website](http://www.servant.dev/). -If you need help, drop by the IRC channel (#servant on freenode) or [mailing +If you need help, drop by the IRC channel (#haskell-servant on libera.chat) or [mailing list](https://groups.google.com/forum/#!forum/haskell-servant). ## Contributing @@ -32,7 +32,7 @@ See `CONTRIBUTING.md` - It's a good idea to separate these steps, as tests often pass, if they compile :) - See `cabal.project` to selectively `allow-newer` - If some packages are broken, on your discretisation there are two options: - - Fix them and make PRs: it's good idea to test against older `servant` version too. + - Fix them and make PRs: it's a good idea to test against older `servant` version too. - Temporarily comment out broken package - If you make a commit for `servant-universe`, you can use it as submodule in private projects to test even more - When ripples are cleared out: @@ -40,29 +40,9 @@ See `CONTRIBUTING.md` - `git push --tags` - `cabal sdist` and `cabal upload` -## travis +## TechEmpower framework benchmarks -`.travis.yml` is generated using `make-travis-yml` tool, in -[multi-ghc-travis](https://github.com/haskell-hvr/multi-ghc-travis) repository. - -To regenerate the script use (*note:* atm you need to comment `doc/cookbook/` packages). - -```sh -runghc ~/Documents/other-haskell/multi-ghc-travis/make_travis_yml_2.hs regenerate -``` - -In case Travis jobs fail due failing build of dependency, you can temporarily -add `constraints` to the `cabal.project`, and regenerate the `.travis.yml`. -For example, the following will disallow single `troublemaker-13.37` package version: - -``` -constraints: - troublemaker <13.37 && > 13.37 -``` - -## TechEmpower framework bechmarks - -We develop & maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/ +We develop and maintain the servant TFB entry in https://github.com/haskell-servant/FrameworkBenchmarks/ To verify (i.e. compile and test that it works) @@ -82,4 +62,10 @@ To compare with `reitit` (Clojure framework) ./tfb --mode benchmark --test reitit reitit-async reitit-jdbc servant servant-beam servant-psql-simple --type json plaintext db fortune ``` -And visualise the results at https://www.techempower.com/benchmarks/#section=test +You can see the visualised results at https://www.techempower.com/benchmarks/#section=test + +## Nix + +A developer shell.nix file is provided in the `nix` directory + +See [nix/README.md](nix/README.md) diff --git a/cabal.ghcjs.project b/cabal.ghcjs.project index d7f2c49f..46d74b2c 100644 --- a/cabal.ghcjs.project +++ b/cabal.ghcjs.project @@ -2,9 +2,13 @@ packages: servant/ + servant-client/ servant-client-core/ - servant-jsaddle/ -- we need to tell cabal we are using GHCJS compiler: ghcjs tests: True + +-- Constraints so that reflex-platform provided packages are selected. +constraints: attoparsec == 0.13.2.2 +constraints: hashable == 1.3.0.0 diff --git a/cabal.haskell-ci b/cabal.haskell-ci deleted file mode 100644 index ac041d53..00000000 --- a/cabal.haskell-ci +++ /dev/null @@ -1,25 +0,0 @@ -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 - --- We have inplace packages (servant-js) so we skip installing dependencies in a separate step -install-dependencies: False - --- this speed-ups the build a little, but we have to check these for release -no-tests-no-benchmarks: False -unconstrained: False - --- Don't run cabal check, as cookbook examples won't pass it -cabal-check: False - --- ghc-options: -j2 -jobs: :2 diff --git a/cabal.project b/cabal.project index 4f29900b..04b29bd5 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,11 @@ packages: servant/ + servant-auth/servant-auth + servant-auth/servant-auth-client + servant-auth/servant-auth-docs + servant-auth/servant-auth-server + servant-auth/servant-auth-swagger + servant-client/ servant-client-core/ servant-http-streams/ @@ -22,17 +28,20 @@ packages: packages: doc/cookbook/basic-auth doc/cookbook/curl-mock + doc/cookbook/custom-errors doc/cookbook/basic-streaming doc/cookbook/db-postgres-pool --- doc/cookbook/db-sqlite-simple + doc/cookbook/db-sqlite-simple doc/cookbook/file-upload doc/cookbook/generic - -- doc/cookbook/hoist-server-with-context --- doc/cookbook/https - -- doc/cookbook/jwt-and-basic-auth/ + doc/cookbook/hoist-server-with-context + doc/cookbook/https + doc/cookbook/jwt-and-basic-auth doc/cookbook/pagination -- doc/cookbook/sentry - doc/cookbook/testing + -- Commented out because servant-quickcheck currently doesn't build. + -- doc/cookbook/testing + doc/cookbook/uverb doc/cookbook/structuring-apis doc/cookbook/using-custom-monad doc/cookbook/using-free-client @@ -47,21 +56,20 @@ constraints: foundation >=0.0.14, memory <0.14.12 || >0.14.12 -allow-newer: aeson-pretty-0.8.7:base-compat - -allow-newer: vault-0.3.1.2:hashable -allow-newer: psqueues-0.2.7.1:hashable -allow-newer: sqlite-simple-0.4.16.0:semigroups -allow-newer: direct-sqlite-2.3.24:semigroups -allow-newer: io-streams-1.5.1.0:network -allow-newer: io-streams-1.5.1.0:primitive -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 +constraints: semigroups ^>=0.19 + +-- allow-newer: sqlite-simple-0.4.16.0:semigroups +-- allow-newer: direct-sqlite-2.3.24:semigroups -- needed for doctests write-ghc-environment-files: always + +-- https://github.com/chordify/haskell-servant-pagination/pull/12 +allow-newer: servant-pagination-2.2.2:servant +allow-newer: servant-pagination-2.2.2:servant-server + +allow-newer: servant-js:servant + +-- ghc 9 +allow-newer: tdigest:base diff --git a/changelog.d/1432 b/changelog.d/1432 new file mode 100644 index 00000000..f88207b9 --- /dev/null +++ b/changelog.d/1432 @@ -0,0 +1,9 @@ +synopsis: Fixes encoding of URL parameters in servant-client +prs: #1432 +issues: #1418 +description: { +Some applications use query parameters to pass arbitrary (non-unicode) binary +data. This change modifies how servant-client handles query parameters, so +that application developers can use `ToHttpApiData` to marshal binary data into +query parameters. +} diff --git a/changelog.d/1477 b/changelog.d/1477 new file mode 100644 index 00000000..52432378 --- /dev/null +++ b/changelog.d/1477 @@ -0,0 +1,9 @@ +synopsis: Enable FlexibleContexts in Servant.API.ContentTypes +prs: #1477 + +description: { + +Starting with GHC 9.2, UndecidableInstances no longer implies FlexibleContexts. +Add this extension where it's needed to make compilation succeed. + +} diff --git a/changelog.d/issue1028 b/changelog.d/issue1028 deleted file mode 100644 index 73cede30..00000000 --- a/changelog.d/issue1028 +++ /dev/null @@ -1,18 +0,0 @@ -synopsis: Add NoContentVerb -prs: #1228 #1219 -issues: #1028 -significance: significant - -description: { - -The `NoContent` API endpoints should now use `NoContentVerb` combinator. -The API type changes are usually of the kind - -```diff -- :<|> PostNoContent '[JSON] NoContent -+ :<|> PostNoContent -``` - -i.e. one doesn't need to specify the content-type anymore. There is no content. - -} diff --git a/changelog.d/issue1200 b/changelog.d/issue1200 deleted file mode 100644 index 885a2571..00000000 --- a/changelog.d/issue1200 +++ /dev/null @@ -1,12 +0,0 @@ -synopsis: Fix Verb with headers checking content type differently -packages: servant-client-core servant-client -prs: #1204 -issues: #1200 -packages: servant-client servant-client-core servant-http-streams - -description: { - -For `Verb`s with response `Headers`, the implementation didn't check -for the content-type of the response. Now it does. - -} diff --git a/changelog.d/issue1240 b/changelog.d/issue1240 deleted file mode 100644 index dce11a69..00000000 --- a/changelog.d/issue1240 +++ /dev/null @@ -1,16 +0,0 @@ -synopsis: Merge documentation from duplicate routes -packages: servant-docs -prs: #1241 -issues: #1240 - -description: { - -Servant supports defining the same route multiple times with different -content-types and result-types, but servant-docs was only documenting -the first of copy of such duplicated routes. It now combines the -documentation from all the copies. - -Unfortunately, it is not yet possible for the documentation to specify -multiple status codes. - -} diff --git a/changelog.d/jsaddle b/changelog.d/jsaddle deleted file mode 100644 index 02dcf5b4..00000000 --- a/changelog.d/jsaddle +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Progress on servant-jsaddle -packages: servant-jsaddle -prs: #1216 diff --git a/changelog.d/pr1156 b/changelog.d/pr1156 deleted file mode 100644 index 91726ae9..00000000 --- a/changelog.d/pr1156 +++ /dev/null @@ -1,17 +0,0 @@ -synopsis: `Capture` can be `Lenient` -issues: #1155 -prs: #1156 -significance: significant -description: { - -You can specify a lenient capture as - -```haskell -:<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET -``` - -which will make the capture always succeed. Handlers will be of the -type `Either String CapturedType`, where `Left err` represents -the possible parse failure. - -} diff --git a/changelog.d/pr1190 b/changelog.d/pr1190 deleted file mode 100644 index e6a308c4..00000000 --- a/changelog.d/pr1190 +++ /dev/null @@ -1,7 +0,0 @@ -synopsis: Add sponsorship button -prs: #1190 -description: { - -[Well-Typed](https://www.well-typed.com/) - -} diff --git a/changelog.d/pr1194 b/changelog.d/pr1194 deleted file mode 100644 index 53136662..00000000 --- a/changelog.d/pr1194 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Prevent race-conditions in testing -packages: servant-docs -prs: #1194 diff --git a/changelog.d/pr1197 b/changelog.d/pr1197 deleted file mode 100644 index bc041c62..00000000 --- a/changelog.d/pr1197 +++ /dev/null @@ -1,4 +0,0 @@ -synopsis: `HasClient` instance for `Stream` with `Headers` -packages: servant-client servant-client servant-http-streams -prs: #1197 -issues: #1170 diff --git a/changelog.d/pr1201 b/changelog.d/pr1201 deleted file mode 100644 index 0724fc38..00000000 --- a/changelog.d/pr1201 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Remove unused extensions from cabal file -packages: servant -prs: #1201 diff --git a/changelog.d/pr1213 b/changelog.d/pr1213 deleted file mode 100644 index 3cb5f15b..00000000 --- a/changelog.d/pr1213 +++ /dev/null @@ -1,12 +0,0 @@ -synopsis: Added a function to create Client.Request in ClientEnv -packages: servant-client -significance: significant -prs: #1213 #1255 -description: { - -The new member `makeClientRequest` of `ClientEnv` is used to create -`http-client` `Request` from `servant-client-core` `Request`. -This functionality can be used for example to set -dynamic timeouts for each request. - -} diff --git a/changelog.d/pr1238 b/changelog.d/pr1238 deleted file mode 100644 index 5b0d838c..00000000 --- a/changelog.d/pr1238 +++ /dev/null @@ -1,3 +0,0 @@ -synopsis: Redact the authorization header in Show and exceptions -packages: servant-client -prs: #1238 diff --git a/changelog.d/pr1249 b/changelog.d/pr1249 deleted file mode 100644 index 3a5c772a..00000000 --- a/changelog.d/pr1249 +++ /dev/null @@ -1,15 +0,0 @@ -synopsis: use queryString to parse QueryParam, QueryParams and QueryFlag -packages: servant-server -prs: #1249 #1262 -significance: significant -description: { - -Some APIs need query parameters rewriting, e.g. in order to support - for multiple casing (camel, snake, etc) or something to that effect. - -This could be easily achieved by using WAI Middleware and modyfing -request's `Query`. But QueryParam, QueryParams and QueryFlag use -`rawQueryString`. By using `queryString` rather then `rawQueryString` -we can enable such rewritings. - -} diff --git a/changelog.d/pr1263 b/changelog.d/pr1263 deleted file mode 100644 index 593bcd1b..00000000 --- a/changelog.d/pr1263 +++ /dev/null @@ -1,11 +0,0 @@ -synopsis: Make packages `build-type: Simple` -packages: servant servant-server -prs: #1263 -significance: significant -description: { - -We used `build-type: Custom`, but it's problematic e.g. -for cross-compiling. The benefit is small, as the doctests -can be run other ways too (though not so conviniently). - -} diff --git a/changelog.d/servant-docs-curl b/changelog.d/servant-docs-curl new file mode 100644 index 00000000..96731337 --- /dev/null +++ b/changelog.d/servant-docs-curl @@ -0,0 +1,16 @@ +synopsis: Add sample cURL requests to generated documentation +prs: #1401 + +description: { + +Add sample cURL requests to generated documentation. + +Those supplying changes to the Request `header` field manually using +lenses will need to add a sample bytestring value. + +`headers <>~ ["unicorn"]` + +becomes + +`headers <>~ [("unicorn", "sample value")]` +} diff --git a/changelog.d/z-changelog-d b/changelog.d/z-changelog-d deleted file mode 100644 index c7e027ff..00000000 --- a/changelog.d/z-changelog-d +++ /dev/null @@ -1,8 +0,0 @@ -synopsis: Try changelog-d for changelog management -prs: #1230 - -description: { - -Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details - -} diff --git a/changelog.d/z-ci-tweaks b/changelog.d/z-ci-tweaks deleted file mode 100644 index 331e5679..00000000 --- a/changelog.d/z-ci-tweaks +++ /dev/null @@ -1,19 +0,0 @@ -synopsis: CI and testing tweaks. -prs: - #1154 - #1157 - #1182 - #1214 - #1229 - #1233 - #1242 - #1247 - #1250 - #1258 - -description: { - -We are experiencing some bitrotting of cookbook recipe dependencies, -therefore some of them aren't build as part of our CI anymore. - -} diff --git a/changelog.d/z-cookbook b/changelog.d/z-cookbook deleted file mode 100644 index 71dca975..00000000 --- a/changelog.d/z-cookbook +++ /dev/null @@ -1,9 +0,0 @@ -synopsis: New cookbook recipes -prs: #1171 #1088 #1198 - -description: { - -- [OIDC Recipe](#TODO) -- [MySQL Recipe](#TODO) - -} diff --git a/changelog.d/z-dependency-upgrades b/changelog.d/z-dependency-upgrades deleted file mode 100644 index 43d72ef0..00000000 --- a/changelog.d/z-dependency-upgrades +++ /dev/null @@ -1,9 +0,0 @@ -synopsis: Dependency upgrades -prs: - #1173 - #1181 - #1183 - #1188 - #1224 - #1245 - #1257 diff --git a/changelog.d/z-documentation-updates b/changelog.d/z-documentation-updates deleted file mode 100644 index 3d8b2215..00000000 --- a/changelog.d/z-documentation-updates +++ /dev/null @@ -1,8 +0,0 @@ -synopsis: Documentation updates -prs: - #1162 - #1174 - #1175 - #1234 - #1244 - #1247 diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..e16129de --- /dev/null +++ b/default.nix @@ -0,0 +1,38 @@ +with (builtins.fromJSON (builtins.readFile ./nix/nixpkgs.json)); +{ + pkgs ? import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/${rev}.tar.gz"; + inherit sha256; + }) {} +, compiler ? "ghc883" +}: +let + overrides = self: super: { + servant = self.callCabal2nix "servant" ./servant {}; + servant-docs = self.callCabal2nix "servant-docs" ./servant-docs {}; + servant-pipes = self.callCabal2nix "servant-pipes" ./servant-pipes {}; + servant-server = self.callCabal2nix "servant-server" ./servant-server {}; + servant-client = self.callCabal2nix "servant-client" ./servant-client {}; + servant-foreign = self.callCabal2nix "servant-foreign" ./servant-foreign {}; + servant-conduit = self.callCabal2nix "servant-conduit" ./servant-conduit {}; + servant-machines = self.callCabal2nix "servant-machines" ./servant-machines {}; + servant-client-core = self.callCabal2nix "servant-client-core" ./servant-client-core {}; + servant-http-streams = self.callCabal2nix "servant-http-streams" ./servant-http-streams {}; + }; + hPkgs = pkgs.haskell.packages.${compiler}.override { inherit overrides; }; +in + with hPkgs; + { + inherit + servant + servant-client + servant-client-core + servant-conduit + servant-docs + servant-foreign + servant-http-streams + servant-machines + servant-pipes + servant-server; + } + diff --git a/doc/cookbook/basic-auth/basic-auth.cabal b/doc/cookbook/basic-auth/basic-auth.cabal index c7112e2f..f46693c0 100644 --- a/doc/cookbook/basic-auth/basic-auth.cabal +++ b/doc/cookbook/basic-auth/basic-auth.cabal @@ -2,13 +2,13 @@ name: cookbook-basic-auth version: 0.1 synopsis: Basic Authentication cookbook example homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-basic-auth main-is: BasicAuth.lhs diff --git a/doc/cookbook/basic-streaming/Streaming.lhs b/doc/cookbook/basic-streaming/Streaming.lhs index 69812a16..e027d8b8 100644 --- a/doc/cookbook/basic-streaming/Streaming.lhs +++ b/doc/cookbook/basic-streaming/Streaming.lhs @@ -8,7 +8,10 @@ In other words, without streaming libraries. - Some basic usage doesn't require usage of streaming libraries, like `conduit`, `pipes`, `machines` or `streaming`. We have bindings for them though. -- This is similar example file, which is bundled with each of the packages (TODO: links) +- Similar example is bundled with each of our streaming library interop packages (see +[servant-pipes](https://github.com/haskell-servant/servant/blob/master/servant-pipes/example/Main.hs), +[servant-conduit](https://github.com/haskell-servant/servant/blob/master/servant-conduit/example/Main.hs) and +[servant-machines](https://github.com/haskell-servant/servant/blob/master/servant-machines/example/Main.hs)) - `SourceT` doesn't have *Prelude* with handy combinators, so we have to write things ourselves. (Note to self: `mapM` and `foldM` would be handy to have). diff --git a/doc/cookbook/basic-streaming/basic-streaming.cabal b/doc/cookbook/basic-streaming/basic-streaming.cabal index 07329d7a..d90ccf24 100644 --- a/doc/cookbook/basic-streaming/basic-streaming.cabal +++ b/doc/cookbook/basic-streaming/basic-streaming.cabal @@ -2,13 +2,13 @@ name: cookbook-basic-streaming version: 2.1 synopsis: Streaming in servant without streaming libs homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-basic-streaming main-is: Streaming.lhs diff --git a/doc/cookbook/curl-mock/CurlMock.lhs b/doc/cookbook/curl-mock/CurlMock.lhs index 57816c71..5ed3b1a2 100644 --- a/doc/cookbook/curl-mock/CurlMock.lhs +++ b/doc/cookbook/curl-mock/CurlMock.lhs @@ -1,7 +1,7 @@ # Generating mock curl calls In this example we will generate curl requests with mock post data from a servant API. -This may be usefull for testing and development purposes. +This may be useful for testing and development purposes. Especially post requests with a request body are tedious to send manually. Also, we will learn how to use the servant-foreign library to generate stuff from servant APIs. @@ -24,7 +24,6 @@ Language extensions and imports: import Control.Lens ((^.)) import Data.Aeson import Data.Aeson.Text -import Data.Monoid ((<>)) import Data.Proxy (Proxy (Proxy)) import Data.Text (Text) import Data.Text.Encoding (decodeUtf8) @@ -86,7 +85,7 @@ listFromAPI :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api ``` This looks a bit confusing... -[Here](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html#t:HasForeignType) is the documentation for the `HasForeign` typeclass. +[Here](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html#t:HasForeign) is the documentation for the `HasForeign` typeclass. We will not go into details here, but this allows us to create a value of type `ftype` for any type `a` in our API. In our case we want to create a mock of every type `a`. @@ -130,24 +129,12 @@ generateCurl :: (GenerateList Mocked (Foreign Mocked api), HasForeign NoLang Moc generateCurl p host = fmap T.unlines body where - body = foldr (\endp curlCalls -> mCons (generateEndpoint host endp) curlCalls) (return []) + body = mapM (generateEndpoint host) $ listFromAPI (Proxy :: Proxy NoLang) (Proxy :: Proxy Mocked) p ``` -To understand this function, better start at the end: - -`listFromAPI` gives us a list of endpoints. We iterate over them (`foldr`) and call `generateEndpoint` for every endpoint. - -As generate endpoint will not return `Text` but `IO Text` (remember we need some random bits to mock), we cannot just use the cons operator but need to build `IO [Text]` from `IO Text`s. - -``` haskell -mCons :: IO a -> IO [a] -> IO [a] -mCons ele list = - ele >>= \e -> list >>= \l -> return ( e : l ) -``` - - -Now comes the juicy part; accessing the endpoints data: +First, `listFromAPI` gives us a list of `Req Mocked`. Each `Req` describes one endpoint from the API type. +We generate a curl call for each of them using the following helper. ``` haskell generateEndpoint :: Text -> Req Mocked -> IO Text @@ -169,7 +156,7 @@ generateEndpoint host req = `servant-foreign` offers a multitude of lenses to be used with `Req`-values. `reqMethod` gives us a straigthforward `Network.HTTP.Types.Method`, `reqUrl` the url part and so on. -Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign-0.11.1/docs/Servant-Foreign.html). +Just take a look at [the docs](https://hackage.haskell.org/package/servant-foreign/docs/Servant-Foreign.html). But how do we get our mocked json string? This seems to be a bit to short to be true: @@ -201,7 +188,7 @@ And now, lets hook it all up in our main function: ``` haskell main :: IO () main = - generateCurl api "localhost:8081" >>= (\v -> T.IO.putStrLn v) + generateCurl api "localhost:8081" >>= T.IO.putStrLn ``` Done: @@ -213,6 +200,6 @@ curl -X POST -d '{"email":"wV򝣀_b򆎘:z񁊞򲙲!(3DM V","age":10,"name":"=|W"} ``` This is of course no complete curl call mock generator, many things including path arguments are missing. -But it correctly generate mock calls for simple POST requests. +But it correctly generates mock calls for simple POST requests. Also, we now know how to use `HasForeignType` and `listFromAPI` to generate anything we want. diff --git a/doc/cookbook/curl-mock/curl-mock.cabal b/doc/cookbook/curl-mock/curl-mock.cabal index 0b2a221a..741a72f2 100644 --- a/doc/cookbook/curl-mock/curl-mock.cabal +++ b/doc/cookbook/curl-mock/curl-mock.cabal @@ -2,13 +2,13 @@ name: cookbook-curl-mock version: 0.1 synopsis: Generate curl mock requests cookbook example homepage: http://docs.servant.dev -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbock-curl-mock main-is: CurlMock.lhs diff --git a/doc/cookbook/custom-errors/CustomErrors.lhs b/doc/cookbook/custom-errors/CustomErrors.lhs new file mode 100644 index 00000000..4e8b773c --- /dev/null +++ b/doc/cookbook/custom-errors/CustomErrors.lhs @@ -0,0 +1,189 @@ +# Customizing errors from Servant + +Servant handles a lot of parsing and validation of the input request. When it can't parse something: query +parameters, URL parts or request body, it will return appropriate HTTP codes like 400 Bad Request. + +These responses will contain the error message in their body without any formatting. However, it is often +desirable to be able to provide custom formatting for these error messages, for example, to wrap them in JSON. + +Recently Servant got a way to add such formatting. This Cookbook chapter demonstrates how to use it. + +Extensions and imports: +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +import Data.Aeson +import Data.Proxy +import Data.Text +import GHC.Generics +import Network.Wai +import Network.Wai.Handler.Warp + +import Servant + +import Data.String.Conversions + (cs) +import Servant.API.ContentTypes +``` + +The API (from `greet.hs` example in Servant sources): + +```haskell +-- | A greet message data type +newtype Greet = Greet { _msg :: Text } + deriving (Generic, Show) + +instance FromJSON Greet +instance ToJSON Greet + +-- API specification +type TestApi = + -- GET /hello/:name?capital={true, false} returns a Greet as JSON + "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet + + -- POST /greet with a Greet as JSON in the request body, + -- returns a Greet as JSON + :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet + + -- DELETE /greet/:greetid + :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + +testApi :: Proxy TestApi +testApi = Proxy + +-- Server-side handlers. +-- +-- There's one handler per endpoint, which, just like in the type +-- that represents the API, are glued together using :<|>. +-- +-- Each handler runs in the 'Handler' monad. +server :: Server TestApi +server = helloH :<|> postGreetH :<|> deleteGreetH + + where helloH name Nothing = helloH name (Just False) + helloH name (Just False) = return . Greet $ "Hello, " <> name + helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name + + postGreetH greet = return greet + + deleteGreetH _ = return NoContent +``` + +## Error formatters + +`servant-server` provides an `ErrorFormatter` type to specify how the error message will be +formatted. A formatter is just a function accepting three parameters: + +- `TypeRep` from `Data.Typeable`: this is a runtime representation of the type of the combinator + (like `Capture` or `ReqBody`) that generated the error. It can be used to display its name (with + `show`) or even dynamically dispatch on the combinator type. See the docs for `Data.Typeable` and + `Type.Reflection` modules. +- `Request`: full information for the request that led to the error. +- `String`: specific error message from the combinator. + +The formatter is expected to produce a `ServerError` which will be returned from the handler. + +Additionally, there is `NotFoundErrorFormatter`, which accepts only `Request` and can customize the +error in case when no route can be matched (HTTP 404). + +Let's make two formatters. First one will wrap our error in a JSON: + +```json +{ + "error": "ERROR MESSAGE", + "combinator": "NAME OF THE COMBINATOR" +} +``` + +Additionally, this formatter will examine the `Accept` header of the request and generate JSON +message only if client can accept it. + +```haskell +customFormatter :: ErrorFormatter +customFormatter tr req err = + let + -- aeson Value which will be sent to the client + value = object ["combinator" .= show tr, "error" .= err] + -- Accept header of the request + accH = getAcceptHeader req + in + -- handleAcceptH is Servant's function that checks whether the client can accept a + -- certain message type. + -- In this case we call it with "Proxy '[JSON]" argument, meaning that we want to return a JSON. + case handleAcceptH (Proxy :: Proxy '[JSON]) accH value of + -- If client can't handle JSON, we just return the body the old way + Nothing -> err400 { errBody = cs err } + -- Otherwise, we return the JSON formatted body and set the "Content-Type" header. + Just (ctypeH, body) -> err400 + { errBody = body + , errHeaders = [("Content-Type", cs ctypeH)] + } + +notFoundFormatter :: NotFoundErrorFormatter +notFoundFormatter req = + err404 { errBody = cs $ "Not found path: " <> rawPathInfo req } +``` + +If you don't need to react to the `Accept` header, you can just unconditionally return the JSON like +this (with `encode` from `Data.Aeson`): + +``` +err400 + { errBody = encode body + , errHeaders = [("Content-Type", "application/json")] + } +``` + +## Passing formatters to Servant + +Servant uses the Context to configure formatters. You only need to add a value of type +`ErrorFormatters` to your context. This is a record with the following fields: + +- `bodyParserErrorFormatter :: ErrorFormatter` +- `urlParseErrorFormatter :: ErrorFormatter` +- `headerParseErrorFormatter :: ErrorFormatter` +- `notFoundErrorFormatter :: NotFoundErrorFormatter` + +Default formatters are exported as `defaultErrorFormatters`, so you can use record update syntax to +set the only ones you need: + +```haskell +customFormatters :: ErrorFormatters +customFormatters = defaultErrorFormatters + { bodyParserErrorFormatter = customFormatter + , notFoundErrorFormatter = notFoundFormatter + } +``` + +And at last, use `serveWithContext` to run your server as usual: + +```haskell +app :: Application +app = serveWithContext testApi (customFormatters :. EmptyContext) server + +main :: IO () +main = run 8000 app +``` + +Now if we try to request something with a wrong body, we will get a nice error: + +``` +$ http -j POST localhost:8000/greet 'foo=bar' +HTTP/1.1 400 Bad Request +Content-Type: application/json;charset=utf-8 +Date: Fri, 17 Jul 2020 13:34:18 GMT +Server: Warp/3.3.12 +Transfer-Encoding: chunked + +{ + "combinator": "ReqBody'", + "error": "Error in $: parsing Main.Greet(Greet) failed, key \"_msg\" not found" +} +``` + +Notice the `Content-Type` header set by our combinator. diff --git a/doc/cookbook/custom-errors/custom-errors.cabal b/doc/cookbook/custom-errors/custom-errors.cabal new file mode 100644 index 00000000..6677bf59 --- /dev/null +++ b/doc/cookbook/custom-errors/custom-errors.cabal @@ -0,0 +1,25 @@ +name: cookbook-custom-errors +version: 0.1 +synopsis: Return custom error messages from combinators +homepage: http://docs.servant.dev +license: BSD-3-Clause +license-file: ../../../servant/LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 + +executable cookbook-custom-errors + main-is: CustomErrors.lhs + build-depends: base == 4.* + , aeson + , servant + , servant-server + , string-conversions + , text + , wai + , warp + default-language: Haskell2010 + ghc-options: -Wall -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit diff --git a/doc/cookbook/db-mysql-basics/MysqlBasics.lhs b/doc/cookbook/db-mysql-basics/MysqlBasics.lhs index 01f0f884..1040ea8c 100644 --- a/doc/cookbook/db-mysql-basics/MysqlBasics.lhs +++ b/doc/cookbook/db-mysql-basics/MysqlBasics.lhs @@ -2,7 +2,7 @@ This doc will walk through a single-module implementation of a servant API connecting to a MySQL database. It will also include some basic CRUD operations. -Once you can wrap your head around this implemenation, understanding more complex features like resource pools would be beneficial next steps. +Once you can wrap your head around this implementation, understanding more complex features like resource pools would be beneficial next steps. The only *prerequisite* is that you have a MySQL database open on port 3306 of your machine. Docker is an easy way to manage this. diff --git a/doc/cookbook/db-mysql-basics/mysql-basics.cabal b/doc/cookbook/db-mysql-basics/mysql-basics.cabal index 98c07768..62097b15 100644 --- a/doc/cookbook/db-mysql-basics/mysql-basics.cabal +++ b/doc/cookbook/db-mysql-basics/mysql-basics.cabal @@ -2,7 +2,7 @@ name: mysql-basics version: 0.1.0.0 synopsis: Simple MySQL API cookbook example homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com diff --git a/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal b/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal index 10719272..d500ed40 100644 --- a/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal +++ b/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal @@ -2,13 +2,13 @@ name: cookbook-db-postgres-pool version: 0.1 synopsis: Simple PostgreSQL connection pool cookbook example homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-db-postgres-pool main-is: PostgresPool.lhs diff --git a/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal b/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal index 9f4e2004..e4e13def 100644 --- a/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal +++ b/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal @@ -2,13 +2,13 @@ name: cookbook-db-sqlite-simple version: 0.1 synopsis: Simple SQLite DB cookbook example homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-db-sqlite-simple main-is: DBConnection.lhs @@ -23,7 +23,7 @@ executable cookbook-db-sqlite-simple , http-types >= 0.12 , markdown-unlit >= 0.4 , http-client >= 0.5 - , sqlite-simple >= 0.4 + , sqlite-simple >= 0.4.5.0 , transformers default-language: Haskell2010 ghc-options: -Wall -pgmL markdown-unlit diff --git a/doc/cookbook/file-upload/FileUpload.lhs b/doc/cookbook/file-upload/FileUpload.lhs index 49c8cdd5..87a294d3 100644 --- a/doc/cookbook/file-upload/FileUpload.lhs +++ b/doc/cookbook/file-upload/FileUpload.lhs @@ -90,8 +90,8 @@ startServer = run 8080 (serve api upload) Finally, a main function that brings up our server and sends some test request with `http-client` (and not -servant-client this time, has servant-multipart does not -yet have support for client generation. +servant-client this time, as servant-multipart does not +yet have support for client generation). ``` haskell main :: IO () diff --git a/doc/cookbook/file-upload/file-upload.cabal b/doc/cookbook/file-upload/file-upload.cabal index e97773d3..3d67687c 100644 --- a/doc/cookbook/file-upload/file-upload.cabal +++ b/doc/cookbook/file-upload/file-upload.cabal @@ -2,13 +2,13 @@ name: cookbook-file-upload version: 0.1 synopsis: File upload cookbook example homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-file-upload main-is: FileUpload.lhs diff --git a/doc/cookbook/generic/Generic.lhs b/doc/cookbook/generic/Generic.lhs index 29f33052..45180230 100644 --- a/doc/cookbook/generic/Generic.lhs +++ b/doc/cookbook/generic/Generic.lhs @@ -43,13 +43,13 @@ api :: Proxy (ToServantApi Routes) api = genericApi (Proxy :: Proxy Routes) ``` -It's recommented to use `genericApi` function, as then you'll get +It's recommended to use `genericApi` function, as then you'll get better error message, for example if you forget to `derive Generic`. ## Links The clear advantage of record-based generics approach, is that -we can get safe links very conviently. We don't need to define endpoint types, +we can get safe links very conveniently. We don't need to define endpoint types, as field accessors work as proxies: ```haskell @@ -67,7 +67,7 @@ routesLinks = allFieldLinks ## Client Even more power starts to show when we generate a record of client functions. -Here we use `genericClientHoist` function, which let us simultaneously +Here we use `genericClientHoist` function, which lets us simultaneously hoist the monad, in this case from `ClientM` to `IO`. ```haskell diff --git a/doc/cookbook/generic/generic.cabal b/doc/cookbook/generic/generic.cabal index a5908beb..4b089c4e 100644 --- a/doc/cookbook/generic/generic.cabal +++ b/doc/cookbook/generic/generic.cabal @@ -2,13 +2,13 @@ name: cookbook-generic version: 0.1 synopsis: Using custom monad to pass a state between handlers homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-using-custom-monad main-is: Generic.lhs diff --git a/doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs b/doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs index ff6a2192..2c50c2e9 100644 --- a/doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs +++ b/doc/cookbook/hoist-server-with-context/HoistServerWithContext.lhs @@ -254,7 +254,7 @@ loginHandler cookieSettings jwtSettings form = do liftIO $ pushLogStrLn logset $ toLogStr logMsg throwError err401 Just applyCookies -> do - let successMsg = logMsg{message = "AdminUser succesfully authenticated!"} + let successMsg = logMsg{message = "AdminUser successfully authenticated!"} liftIO $ pushLogStrLn logset $ toLogStr successMsg pure $ applyCookies successMsg loginHandler _ _ _ = throwError err401 @@ -287,7 +287,7 @@ mkApp cfg cs jwts ctx = (flip runReaderT ctx) (adminServer cs jwts) ``` -One footenote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object +One footnote: because we'd like our logs to be in JSON form, we'll also create a `Middleware` object so that `Warp` *also* will emit logs as JSON. This will ensure *all* logs are emitted as JSON: ```haskell diff --git a/doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal b/doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal index 66407a45..ea734e89 100644 --- a/doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal +++ b/doc/cookbook/hoist-server-with-context/hoist-server-with-context.cabal @@ -4,14 +4,14 @@ synopsis: JWT and basic access authentication with a Custom Monad coo description: Using servant-auth to support both JWT-based and basic authentication. homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com category: Servant build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-hoist-server-with-context main-is: HoistServerWithContext.lhs @@ -24,7 +24,7 @@ executable cookbook-hoist-server-with-context , servant , servant-server , servant-auth >= 0.3.2 - , servant-auth-server + , servant-auth-server >= 0.4.4.0 , time , warp >= 3.2 , wai >= 3.2 diff --git a/doc/cookbook/https/Https.lhs b/doc/cookbook/https/Https.lhs index de188463..6a95824d 100644 --- a/doc/cookbook/https/Https.lhs +++ b/doc/cookbook/https/Https.lhs @@ -34,16 +34,16 @@ app = serve api server ``` It's now time to actually run the `Application`. -The [`warp-tls`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html) +The [`warp-tls`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html) package provides two functions for running an `Application`, called -[`runTLS`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS) -and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket). +[`runTLS`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS) +and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket). We will be using the first one. It takes two arguments, -[the TLS settings](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings) +[the TLS settings](https://hackage.haskell.org/package/warp-tls/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings) (certificates, keys, ciphers, etc) -and [the warp settings](https://hackage.haskell.org/package/warp-3.2.12/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings) +and [the warp settings](https://hackage.haskell.org/package/warp/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings) (port, logger, etc). We will be using very simple settings for this example but you are of diff --git a/doc/cookbook/https/https.cabal b/doc/cookbook/https/https.cabal index b0d793b6..045b4888 100644 --- a/doc/cookbook/https/https.cabal +++ b/doc/cookbook/https/https.cabal @@ -2,13 +2,13 @@ name: cookbook-https version: 0.1 synopsis: HTTPS cookbook example homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-https main-is: Https.lhs @@ -17,7 +17,7 @@ executable cookbook-https , servant-server , wai >= 3.2 , warp >= 3.2 - , warp-tls >= 3.2 + , warp-tls >= 3.2.9 , markdown-unlit >= 0.4 default-language: Haskell2010 ghc-options: -Wall -pgmL markdown-unlit diff --git a/doc/cookbook/index.rst b/doc/cookbook/index.rst index ac0ed5cf..9d4601a7 100644 --- a/doc/cookbook/index.rst +++ b/doc/cookbook/index.rst @@ -25,6 +25,8 @@ you name it! db-postgres-pool/PostgresPool.lhs using-custom-monad/UsingCustomMonad.lhs using-free-client/UsingFreeClient.lhs + custom-errors/CustomErrors.lhs + uverb/UVerb.lhs basic-auth/BasicAuth.lhs basic-streaming/Streaming.lhs jwt-and-basic-auth/JWTAndBasicAuth.lhs diff --git a/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal b/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal index fd5cdbdf..53d4c650 100644 --- a/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal +++ b/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal @@ -4,14 +4,14 @@ synopsis: JWT and basic access authentication cookbook example description: Using servant-auth to support both JWT-based and basic authentication. homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com category: Servant build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-jwt-and-basic-auth main-is: JWTAndBasicAuth.lhs @@ -22,7 +22,7 @@ executable cookbook-jwt-and-basic-auth , servant , servant-client , servant-server - , servant-auth ==0.3.* + , servant-auth == 0.4.* , servant-auth-server >= 0.3.1.0 , warp >= 3.2 , wai >= 3.2 diff --git a/doc/cookbook/open-id-connect/OpenIdConnect.cabal b/doc/cookbook/open-id-connect/OpenIdConnect.cabal index eae9fb7e..c156f8d7 100644 --- a/doc/cookbook/open-id-connect/OpenIdConnect.cabal +++ b/doc/cookbook/open-id-connect/OpenIdConnect.cabal @@ -2,13 +2,13 @@ name: open-id-connect version: 0.1 synopsis: OpenId Connect with Servant example homepage: http://haskell-servant.readthedocs.org/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >= 1.10 -tested-with: GHC==8.4.4, GHC==8.6.5 +tested-with: GHC==8.6.5 executable cookbook-openidconnect main-is: OpenIdConnect.lhs diff --git a/doc/cookbook/open-id-connect/OpenIdConnect.lhs b/doc/cookbook/open-id-connect/OpenIdConnect.lhs index f94a9219..6b4d0ca2 100644 --- a/doc/cookbook/open-id-connect/OpenIdConnect.lhs +++ b/doc/cookbook/open-id-connect/OpenIdConnect.lhs @@ -8,8 +8,8 @@ some login token would be saved in the user agent local storage. Workflow: -1. user is presentend with a login button, -2. when the user click on the button it is redirected to the OIDC +1. user is presented with a login button, +2. when the user clicks on the button it is redirected to the OIDC provider, 3. the user login in the OIDC provider, 4. the OIDC provider will redirect the user and provide a `code`, @@ -221,9 +221,9 @@ The `AuthInfo` is about the infos we can grab from OIDC provider. To be more precise, the user should come with a `code` (a token) and POSTing that code to the correct OIDC provider endpoint should return a JSON -object. One of the field should be named `id_token` which should be a -JWT containing all the informations we need. Depending on the scopes we -asked we might get more informations. +object. One of the fields should be named `id_token` which should be a +JWT containing all the information we need. Depending on the scopes we +asked we might get more information. ``` haskell -- | @AuthInfo@ @@ -248,16 +248,16 @@ instance JSON.ToJSON AuthInfo where type LoginHandler = AuthInfo -> IO (Either Text User) ``` -The `handleLoggedIn` is that part that will retrieve the informations from +The `handleLoggedIn` is that part that will retrieve the information from the user once he is redirected from the OIDC Provider after login. If the user is redirected to the `redirect_uri` but with an `error` query -parameter then it means something goes wrong. +parameter then it means something went wrong. If there is no error query param but a `code` query param it means the user -sucessfully logged in. From there we need to make a request to the token -endpoint of the OIDC provider. Its a POST that should contains the code -as well as the client id & secret. -This is the role of the `requestTokens` to make this HTTP POST. +successfully logged in. From there we need to make a request to the token +endpoint of the OIDC provider. It's a POST that should contain the code +as well as the client id and secret. +Making this HTTP POST is the responsibility of `requestTokens`. From there we extract the `claims` of the JWT contained in one of the value of the JSON returned by the POST HTTP Request. @@ -329,12 +329,12 @@ data Customer = Customer { } ``` -Here is the code that display the homepage. +Here is the code that displays the homepage. It should contain a link to the the `/login` URL. -When the user will click on this link it will be redirected to Google login page -with some generated informations. +When the user clicks on this link it will be redirected to Google login page +with some generated information. -The page also display the content of the local storage. +The page also displays the content of the local storage. And in particular the items `api-key` and `user-id`. Those items should be set after a successful login when the user is redirected to `/login/cb`. @@ -366,7 +366,7 @@ instance ToMarkup Homepage where We need some helpers to generate random string for generating state and API Keys. ``` haskell --- | generate a random Bystestring, not necessarily extremely good randomness +-- | generate a random ByteString, not necessarily extremely good randomness -- still the password will be long enough to be very difficult to crack genRandomBS :: IO ByteString genRandomBS = do diff --git a/doc/cookbook/pagination/Pagination.lhs b/doc/cookbook/pagination/Pagination.lhs index 7c2c0e70..2bbb22ec 100644 --- a/doc/cookbook/pagination/Pagination.lhs +++ b/doc/cookbook/pagination/Pagination.lhs @@ -18,7 +18,7 @@ For example: `Range: createdAt 2017-01-15T23:14:67.000Z; offset 5; order desc` i the client is willing to retrieve the next batch of document in descending order that were created after the fifteenth of January, skipping the first 5. -As a response, the server may return the list of corresponding document, and augment the +As a response, the server may return the list of corresponding documents, and augment the response with 3 headers: - `Accept-Ranges`: A comma-separated list of fields upon which a range can be defined @@ -127,7 +127,7 @@ defaultRange = getDefaultRange (Proxy @Color) ``` -Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definintion +Note that `getFieldValue :: Proxy "name" -> Color -> String` is the minimal complete definition of the class. Yet, you can define `getRangeOptions` to provide different parsing options (see the last section of this guide). In the meantime, we've also defined a `defaultRange` as it will come in handy when defining our handler. @@ -148,7 +148,7 @@ type MyHeaders = ``` `PageHeaders` is a type alias provided by the library to declare the necessary response headers -we mentionned in introduction. Expanding the alias boils down to the following: +we mentioned in introduction. Expanding the alias boils down to the following: ``` haskell -- type MyHeaders = @@ -165,7 +165,7 @@ not, _servant-pagination_ provides an easy way to lift a collection of resources #### Server Time to connect the last bits by defining the server implementation of our colorful API. The `Ranges` -type we've defined above (tight to the `Range` HTTP header) indicates the server to parse any `Range` +type we've defined above (tied to the `Range` HTTP header) indicates the server to parse any `Range` header, looking for the format defined in introduction with fields and target types we have just declared. If no such header is provided, we will end up receiving `Nothing`. Otherwise, it will be possible to _extract_ a `Range` from our `Ranges`. @@ -192,7 +192,7 @@ the format we defined, where `` here can only be `name` and `` mus - `Range: [][; offset ][; limit ][; order ]` Beside the target field, everything is pretty much optional in the `Range` HTTP header. Missing parts -are deducted from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all +are deduced from the `RangeOptions` that are part of the `HasPagination` instance. Therefore, all following examples are valid requests to send to our server: - 1 - `curl http://localhost:1442/colors -vH 'Range: name'` @@ -219,7 +219,7 @@ The previous ranges reads as follows: Note that in the simple above scenario, there's no ambiguity with `extractRange` and `returnRange` because there's only one possible `Range` defined on our resource. Yet, as you've most probably noticed, the `Ranges` combinator accepts a list of fields, each of which must declare a `HasPagination` -instance. Doing so will make the other helper functions more ambiguous and type annotation are +instance. Doing so will make the other helper functions more ambiguous and type annotations are highly likely to be needed. @@ -235,8 +235,8 @@ instance HasPagination Color "hex" where #### Parsing Options By default, `servant-pagination` provides an implementation of `getRangeOptions` for each -`HasPagination` instance. However, this can be overwritten when defining the instance to provide -your own options. This options come into play when a `Range` header is received and isn't fully +`HasPagination` instance. However, this can be overridden when defining the instance to provide +your own options. These options come into play when a `Range` header is received and isn't fully specified (`limit`, `offset`, `order` are all optional) to provide default fallback values for those. For instance, let's say we wanted to change the default limit to `5` in a new range on diff --git a/doc/cookbook/pagination/pagination.cabal b/doc/cookbook/pagination/pagination.cabal index 387c5dec..18c3b4a3 100644 --- a/doc/cookbook/pagination/pagination.cabal +++ b/doc/cookbook/pagination/pagination.cabal @@ -2,13 +2,13 @@ name: cookbook-pagination version: 2.1 synopsis: Pagination with Servant example homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-pagination main-is: Pagination.lhs diff --git a/doc/cookbook/sentry/Sentry.lhs b/doc/cookbook/sentry/Sentry.lhs index c0330cfd..e2e41416 100644 --- a/doc/cookbook/sentry/Sentry.lhs +++ b/doc/cookbook/sentry/Sentry.lhs @@ -79,14 +79,14 @@ It does three things. First it initializes the service which will communicate wi - the Sentry `DSN`, which is obtained when creating a new project on Sentry - a default way to update sentry fields, where we use the identity function -- an event trasport, which generally would be `sendRecord`, an HTTPS capable trasport which uses http-conduit +- an event transport, which generally would be `sendRecord`, an HTTPS capable transport which uses http-conduit - a fallback handler, which we choose to be `silentFallback` since later we are logging to the console anyway. In the second step it actually sends our message to Sentry with the `register` function. Its arguments are: - the configured Sentry service which we just created - the name of the logger -- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell-0.1.2.0/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options) +- the error level (see [SentryLevel](https://hackage.haskell.org/package/raven-haskell/docs/System-Log-Raven-Types.html#t:SentryLevel) for the possible options) - the message we want to send - an update function to handle the specific `SentryRecord` diff --git a/doc/cookbook/sentry/sentry.cabal b/doc/cookbook/sentry/sentry.cabal index 30b31cd5..282062b9 100644 --- a/doc/cookbook/sentry/sentry.cabal +++ b/doc/cookbook/sentry/sentry.cabal @@ -2,13 +2,13 @@ name: cookbook-sentry version: 0.1 synopsis: Collecting runtime exceptions using Sentry homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-sentry main-is: Sentry.lhs diff --git a/doc/cookbook/structuring-apis/StructuringApis.lhs b/doc/cookbook/structuring-apis/StructuringApis.lhs index c59b01db..a8a82258 100644 --- a/doc/cookbook/structuring-apis/StructuringApis.lhs +++ b/doc/cookbook/structuring-apis/StructuringApis.lhs @@ -144,7 +144,7 @@ simpleAPIServer :: m [a] -> (i -> m a) -> (a -> m NoContent) - -> Server (SimpleAPI name a i) m + -> ServerT (SimpleAPI name a i) m simpleAPIServer listAs getA postA = listAs :<|> getA :<|> postA diff --git a/doc/cookbook/structuring-apis/structuring-apis.cabal b/doc/cookbook/structuring-apis/structuring-apis.cabal index f6fb631c..323fa7f1 100644 --- a/doc/cookbook/structuring-apis/structuring-apis.cabal +++ b/doc/cookbook/structuring-apis/structuring-apis.cabal @@ -2,13 +2,13 @@ name: cookbook-structuring-apis version: 0.1 synopsis: Example that shows how APIs can be structured homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-structuring-apis main-is: StructuringApis.lhs diff --git a/doc/cookbook/testing/testing.cabal b/doc/cookbook/testing/testing.cabal index 28ed9691..56067a8c 100644 --- a/doc/cookbook/testing/testing.cabal +++ b/doc/cookbook/testing/testing.cabal @@ -3,14 +3,14 @@ version: 0.0.1 synopsis: Common testing patterns in Servant apps description: This recipe includes various strategies for writing tests for Servant. homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com category: Servant build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-testing main-is: Testing.lhs @@ -23,7 +23,7 @@ executable cookbook-testing , servant , servant-client , servant-server - , servant-quickcheck + , servant-quickcheck >= 0.0.10 , http-client , http-types >= 0.12 , hspec diff --git a/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs b/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs index baf1e095..e0336065 100644 --- a/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs +++ b/doc/cookbook/using-custom-monad/UsingCustomMonad.lhs @@ -1,6 +1,6 @@ # Using a custom monad -In this section we will create and API for a book shelf without any backing DB storage. +In this section we will create an API for a book shelf without any backing DB storage. We will keep state in memory and share it between requests using `Reader` monad and `STM`. We start with a pretty standard set of imports and definition of the model: diff --git a/doc/cookbook/using-custom-monad/using-custom-monad.cabal b/doc/cookbook/using-custom-monad/using-custom-monad.cabal index 701d5116..8cac3fc4 100644 --- a/doc/cookbook/using-custom-monad/using-custom-monad.cabal +++ b/doc/cookbook/using-custom-monad/using-custom-monad.cabal @@ -2,13 +2,13 @@ name: cookbook-using-custom-monad version: 0.1 synopsis: Using custom monad to pass a state between handlers homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-using-custom-monad main-is: UsingCustomMonad.lhs diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs index d72ad6d5..0185c514 100644 --- a/doc/cookbook/using-free-client/UsingFreeClient.lhs +++ b/doc/cookbook/using-free-client/UsingFreeClient.lhs @@ -141,7 +141,7 @@ and calling the continuation. We should get a `Pure` value. Pure n -> putStrLn $ "Expected 1764, got " ++ show n _ -> - putStrLn "ERROR: didn't got a response" + putStrLn "ERROR: didn't get a response" ``` So that's it. Using `Free` we can evaluate servant clients step-by-step, and diff --git a/doc/cookbook/using-free-client/using-free-client.cabal b/doc/cookbook/using-free-client/using-free-client.cabal index d50bd419..02179703 100644 --- a/doc/cookbook/using-free-client/using-free-client.cabal +++ b/doc/cookbook/using-free-client/using-free-client.cabal @@ -2,13 +2,13 @@ name: cookbook-using-free-client version: 0.1 synopsis: Using Free client homepage: http://docs.servant.dev/ -license: BSD3 +license: BSD-3-Clause license-file: ../../../servant/LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +tested-with: GHC==8.6.5, GHC==8.8.3, GHC ==8.10.7 executable cookbook-using-free-client main-is: UsingFreeClient.lhs diff --git a/doc/cookbook/uverb/UVerb.lhs b/doc/cookbook/uverb/UVerb.lhs new file mode 100644 index 00000000..cc771111 --- /dev/null +++ b/doc/cookbook/uverb/UVerb.lhs @@ -0,0 +1,223 @@ +# Listing alternative responses and exceptions in your API types + +Servant allows you to talk about the exceptions you throw in your API +types. This is not limited to actual exceptions, you can write +handlers that respond with arbitrary open unions of types. + +## Compatibility + +:warning: This cookbook is compatible with GHC 8.6.1 or higher :warning: + +## Preliminaries + +```haskell +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall -Wno-orphans #-} + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (async) +import Control.Monad (when) +import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.Aeson.Encode.Pretty (encodePretty) +import Data.String.Conversions (cs) +import Data.Swagger (ToSchema) +import Data.Typeable (Proxy (Proxy)) +import qualified GHC.Generics as GHC +import qualified Network.HTTP.Client as Client +import qualified Network.Wai.Handler.Warp as Warp +import Servant.API +import Servant.Client +import Servant.Server +import Servant.Swagger +``` + +## The API + +This looks like a `Verb`-based routing table, except that `UVerb` has +no status, and carries a list of response types rather than a single +one. Each entry in the list carries its own response code. + +```haskell +type API = + "fisx" :> Capture "bool" Bool + :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String] + :<|> "arian" + :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser] +``` + +Here are the details: + +```haskell +data FisxUser = FisxUser {name :: String} + deriving (Eq, Show, GHC.Generic) + +instance ToJSON FisxUser +instance FromJSON FisxUser +instance ToSchema FisxUser + +-- | 'HasStatus' allows us to can get around 'WithStatus' if we want +-- to, and associate the status code with our resource types directly. +-- +-- (To avoid orphan instances and make it more explicit what's in the +-- API and what isn't, we could even introduce a newtype 'Resource' +-- that wraps all the types we're using in our routing table, and then +-- define lots of 'HasStatus' instances for @Resource This@ and +-- @Resource That@.) +instance HasStatus FisxUser where + type StatusOf FisxUser = 203 + +data ArianUser = ArianUser + deriving (Eq, Show, GHC.Generic) + +instance ToJSON ArianUser +instance FromJSON ArianUser +instance ToSchema ArianUser +``` + +## Server, Client, Swagger + +You can just respond with any of the elements of the union in handlers. + +```haskell +fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String]) +fisx True = respond (FisxUser "fisx") +fisx False = respond (WithStatus @303 ("still fisx" :: String)) + +arian :: Handler (Union '[WithStatus 201 ArianUser]) +arian = respond (WithStatus @201 ArianUser) +``` + +You can create client functions like you're used to: + +``` +fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String]) +arianClient :: ClientM (Union '[WithStatus 201 ArianUser]) +(fisxClient :<|> arianClient) = client (Proxy @API) +``` + +... and that's basically it! Here are a few sample commands that +show you how the swagger docs look like and how you can handle the +result unions in clients: + +``` +main :: IO () +main = do + putStrLn . cs . encodePretty $ toSwagger (Proxy @API) + _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian) + threadDelay 50000 + mgr <- Client.newManager Client.defaultManagerSettings + let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "") + result <- runClientM (fisxClient True) cenv + print $ foldMapUnion (Proxy @Show) show <$> result + print $ matchUnion @FisxUser <$> result + print $ matchUnion @(WithStatus 303 String) <$> result + pure () +``` + +## Idiomatic exceptions + +Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`. + +```haskell +newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a } + deriving (Functor, Applicative, Monad, MonadTrans) + +-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use +-- underlying monad's instance. +instance MonadError e m => MonadError e (UVerbT xs m) where + throwError = lift . throwError + catchError (UVerbT act) h = UVerbT $ ExceptT $ + runExceptT act `catchError` (runExceptT . unUVerbT . h) + +-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler +-- may use the usual 'return'. +runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs) +runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond) + +-- | Short-circuit 'UVerbT' computation returning one of the response types. +throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a +throwUVerb = UVerbT . ExceptT . fmap Left . respond +``` + +Example usage: + +```haskell +data Foo = Foo Int Int Int + deriving (Show, Eq, GHC.Generic, ToJSON) + deriving HasStatus via WithStatus 200 Foo + +data Bar = Bar + deriving (Show, Eq, GHC.Generic) + +instance ToJSON Bar + +h :: Handler (Union '[Foo, WithStatus 400 Bar]) +h = runUVerbT $ do + when ({- something bad -} True) $ + throwUVerb $ WithStatus @400 Bar + + when ({- really bad -} False) $ + throwError $ err500 + + -- a lot of code here... + + return $ Foo 1 2 3 +``` + +## Related Work + +There is the [issue from +2017](https://github.com/haskell-servant/servant/issues/841) that was +resolved by the introduction of `UVerb`, with a long discussion on +alternative designs. + +[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions) +is a good solution to the problem, but it restricts the user to JSON +and a very specific envelop encoding for the union type, which is +often not acceptable. (One good reason for this design choice is that +it makes writing clients easier, where you need to get to the union +type from one representative, and you don't want to run several +parsers in the hope that the ones that should will always error out so +you can try until the right one returns a value.) + +[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is +another shot at at the problem. It is inspired by +servant-checked-exceptions, so it may be worth taking a closer look. +The README claims that +[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has +some code for generalized error handling. + +In an earier version of the `UVerb` implementation, we have used some +code from +[world-peace](https://hackage.haskell.org/package/world-peace), but +that package itself wasn't flexible enough, and we had to use +[sop-core](https://hackage.haskell.org/package/sop-core) to implement +the `HasServer` instance. + +Here is a blog post we found on the subject: +https://lukwagoallan.com/posts/unifying-servant-server-error-responses + +(If you have anything else, please add it here or let us know.) + +```haskell +main :: IO () +main = return () +``` diff --git a/doc/cookbook/uverb/uverb.cabal b/doc/cookbook/uverb/uverb.cabal new file mode 100644 index 00000000..80dc1b06 --- /dev/null +++ b/doc/cookbook/uverb/uverb.cabal @@ -0,0 +1,35 @@ +name: cookbook-uverb +version: 0.0.1 +synopsis: How to use the 'UVerb' type. +description: Listing alternative responses and exceptions in your API types. +homepage: http://docs.servant.dev/ +license: BSD-3-Clause +license-file: ../../../servant/LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +category: Servant +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.7 + +executable cookbook-uverb + main-is: UVerb.lhs + build-depends: base == 4.* + , aeson >= 1.2 + , aeson-pretty >= 0.8.8 + , async + , http-client + , mtl + , servant + , servant-client + , servant-server + , servant-swagger + , string-conversions + , swagger2 + , wai + , warp + if impl(ghc >= 9) + buildable: False + default-language: Haskell2010 + ghc-options: -Wall -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index 365c33a7..113b8e5f 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -389,3 +389,30 @@ One example for this is if you want to serve a directory of static files along with the rest of your API. But you can plug in everything that is an `Application`, e.g. a whole web application written in any of the web frameworks that support `wai`. + +Be mindful! The `servant-server`'s router works by pattern-matching the +different routes that are composed using `:<|>`. `Raw`, as an escape hatch, +matches any route that hasn't been matched by previous patterns. Therefore, +any subsequent route will be silently ignored. + +``` haskell +type UserAPI14 = Raw + :<|> "users" :> Get '[JSON] [User] + -- In this situation, the /users endpoint + -- will not be reachable because the Raw + -- endpoint matches requests before +``` +A simple way to avoid this pitfall is to either use `Raw` as the last +definition, or to always have it under a static path. + +``` haskell +type UserAPI15 = "files" :> Raw + -- The raw endpoint is under the /files + -- static path, so it won't match /users. + :<|> "users" :> Get '[JSON] [User] + +type UserAPI16 = "users" :> Get '[JSON] [User] + :<|> Raw + -- The Raw endpoint is matched last, so + -- it won't overlap another endpoint. +``` diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index da18b7ee..ded784d4 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -47,7 +47,6 @@ module Authentication where import Data.Aeson (ToJSON) import Data.ByteString (ByteString) import Data.Map (Map, fromList) -import Data.Monoid ((<>)) import qualified Data.Map as Map import Data.Proxy (Proxy (Proxy)) import Data.Text (Text) @@ -108,7 +107,7 @@ API with "private." Additionally, the private parts of our API use the realm for this authentication is `"foo-realm"`). Unfortunately we're not done. When someone makes a request to our `"private"` -API, we're going to need to provide to servant the logic for validifying +API, we're going to need to provide to servant the logic for validating usernames and passwords. This adds a certain conceptual wrinkle in servant's design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup function to servant's new `Context` primitive. @@ -133,7 +132,7 @@ combinator. Using `Context`, we can supply a function of type handler. This will allow the handler to check authentication and return a `User` to downstream handlers if successful. -In practice we wrap `BasicAuthData -> Handler` into a slightly +In practice we wrap `BasicAuthData -> Handler User` into a slightly different function to better capture the semantics of basic authentication: ``` haskell ignore @@ -260,7 +259,7 @@ this. Let's implement a trivial authentication scheme. We will protect our API by looking for a cookie named `"servant-auth-cookie"`. This cookie's value will -contain a key from which we can lookup a `Account`. +contain a key from which we can lookup an `Account`. ```haskell -- | An account type that we "fetch from the database" after @@ -274,7 +273,7 @@ database = fromList [ ("key1", Account "Anne Briggs") , ("key3", Account "Ghédalia Tazartès") ] --- | A method that, when given a password, will return a Account. +-- | A method that, when given a password, will return an Account. -- This is our bespoke (and bad) authentication logic. lookupAccount :: ByteString -> Handler Account lookupAccount key = case Map.lookup key database of @@ -346,7 +345,7 @@ genAuthServerContext = authHandler :. EmptyContext -- | Our API, where we provide all the author-supplied handlers for each end -- point. Note that 'privateDataFunc' is a function that takes 'Account' as an --- argument. We dont' worry about the authentication instrumentation here, +-- argument. We don't worry about the authentication instrumentation here, -- that is taken care of by supplying context genAuthServer :: Server AuthGenAPI genAuthServer = @@ -385,11 +384,11 @@ Creating a generalized, ad-hoc authentication scheme was fairly straight forward: 1. use the `AuthProtect` combinator to protect your API. -2. choose a application-specific data type used by your server when +2. choose an application-specific data type used by your server when authentication is successful (in our case this was `Account`). 3. Create a value of `AuthHandler Request Account` which encapsulates the authentication logic (`Request -> Handler Account`). This function -will be executed everytime a request matches a protected route. +will be executed every time a request matches a protected route. 4. Provide an instance of the `AuthServerData` type family, specifying your application-specific data type returned when authentication is successful (in our case this was `Account`). diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 404ea027..35acee3d 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -161,7 +161,7 @@ The types of the arguments for the functions are the same as for (server-side) r ## Changing the monad the client functions live in Just like `hoistServer` allows us to change the monad in which request handlers -of a web application live in, we also have `hoistClient` for changing the monad +of a web application live, we also have `hoistClient` for changing the monad in which _client functions_ live. Consider the following trivial API: ``` haskell @@ -173,7 +173,7 @@ hoistClientAPI = Proxy We already know how to derive client functions for this API, and as we have seen above they all return results in the `ClientM` monad when using `servant-client`. -However, `ClientM` rarely (or never) is the actual monad we need to use the client +However, `ClientM` is rarely (or never) the actual monad we need to use the client functions in. Sometimes we need to run them in IO, sometimes in a custom monad stack. `hoistClient` is a very simple solution to the problem of "changing" the monad the clients run in. diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs index 91c93c71..047ce55f 100644 --- a/doc/tutorial/Docs.lhs +++ b/doc/tutorial/Docs.lhs @@ -77,7 +77,7 @@ instance ToSample HelloMessage where [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp") , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward") ] - -- mutliple examples to display this time + -- multiple examples to display this time ci :: ClientInfo ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] @@ -108,7 +108,7 @@ apiDocs = docs exampleAPI markdown :: API -> String ``` -That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`. +That lets us see what our API docs look like in markdown, by looking at `markdown apiDocs`. ````````` text ## GET /hello diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs index fbcd3c95..2ba6129f 100644 --- a/doc/tutorial/Javascript.lhs +++ b/doc/tutorial/Javascript.lhs @@ -228,13 +228,13 @@ data CommonGeneratorOptions = CommonGeneratorOptions { -- | function generating function names functionNameBuilder :: FunctionName -> Text - -- | name used when a user want to send the request body (to let you redefine it) + -- | name used when a user wants to send the request body (to let you redefine it) , requestBody :: Text -- | name of the callback parameter when the request was successful , successCallback :: Text -- | name of the callback parameter when the request reported an error , errorCallback :: Text - -- | namespace on which we define the js function (empty mean local var) + -- | namespace on which we define the js function (empty means local var) , moduleName :: Text -- | a prefix that should be prepended to the URL in the generated JS , urlPrefix :: Text diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 4b3ff083..265bd707 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -183,7 +183,7 @@ users2 = [isaac, albert] Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we are going to separate the handlers with `:<|>` too! They must be provided in -the same order as in in the API type. +the same order as in the API type. ``` haskell server2 :: Server UserAPI2 @@ -313,8 +313,8 @@ For reference, here's a list of some combinators from **servant**: ## The `FromHttpApiData`/`ToHttpApiData` classes Wait... How does **servant** know how to decode the `Int`s from the URL? Or how -to decode a `ClientInfo` value from the request body? This is what this and the -following two sections address. +to decode a `ClientInfo` value from the request body? The following three sections will +help us answer these questions. `Capture`s and `QueryParam`s are represented by some textual value in URLs. `Header`s are similarly represented by a pair of a header name and a @@ -620,7 +620,7 @@ In short, this means that a handler of type `Handler a` is simply equivalent to a computation of type `IO (Either ServerError a)`, that is, an IO action that either returns an error or a result. -The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT) +The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl/docs/Control-Monad-Except.html#t:ExceptT) from which `ExceptT` comes is worth looking at. Perhaps most importantly, `ExceptT` and `Handler` are instances of `MonadError`, so `throwError` can be used to return an error from your handler (whereas `return` @@ -634,7 +634,7 @@ kind and abort early. The next two sections cover how to do just that. Other important instances from the list above are `MonadIO m => MonadIO (ExceptT e m)`, and therefore also `MonadIO Handler` as there is a `MonadIO IO` instance. -[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) +[`MonadIO`](http://hackage.haskell.org/package/base/docs/Control-Monad-IO-Class.html#t:MonadIO) is a class from the **transformers** package defined as: ``` haskell ignore @@ -716,7 +716,7 @@ $ curl --verbose http://localhost:8081/myfile.txt > < HTTP/1.1 404 Not Found [snip] -myfile.txt just isnt there, please leave this server alone. +myfile.txt just isn't there, please leave this server alone. $ echo Hello > myfile.txt @@ -818,7 +818,7 @@ If it doesn't exist, the handler will fail with a `404` status code. `serveDirectoryWebApp` uses some standard settings that fit the use case of serving static files for most web apps. You can find out about the other -options in the documentation of the `Servant.Utils.StaticFiles` module. +options in the documentation of the `Servant.Server.StaticFiles` module. ## Nested APIs @@ -1135,7 +1135,7 @@ true ### An arrow is a reader too. In previous versions of `servant` we had an `enter` to do what `hoistServer` -does now. `enter` had a ambitious design goals, but was problematic in practice. +does now. `enter` had an ambitious design goals, but was problematic in practice. One problematic situation was when the source monad was `(->) r`, yet it's handy in practice, because `(->) r` is isomorphic to `Reader r`. @@ -1166,7 +1166,7 @@ back a *stream* of results, served one at a time. Stream endpoints only provide a single content type, and also specify what framing strategy is used to delineate the results. To serve these results, we need to give back a stream producer. Adapters can be written to *Pipes*, *Conduit* and the like, or -written directly as `SourceIO`s. SourceIO builts upon servant's own `SourceT` +written directly as `SourceIO`s. SourceIO builds upon servant's own `SourceT` stream type (it's simpler than *Pipes* or *Conduit*). The API of a streaming endpoint needs to explicitly specify which sort of generator it produces. Note that the generator itself is returned by a diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst index c47bfd1d..213a2c6c 100644 --- a/doc/tutorial/index.rst +++ b/doc/tutorial/index.rst @@ -6,46 +6,10 @@ This is an introductory tutorial to **servant**. Whilst browsing is fine, it mak Any comments, issues or feedback about the tutorial can be submitted to `servant's issue tracker `_. -cabal-install --------- - -The whole tutorial is a `cabal `_ -project and can be built locally as follows: - -.. code-block:: bash - - $ git clone https://github.com/haskell-servant/servant.git - $ cd servant - # build - $ cabal new-build tutorial - # load in ghci to play with it - $ cabal new-repl tutorial - -stack --------- - -The servant `stack `_ template includes the working tutorial. To initialize this template, run: - -.. code-block:: bash - - $ stack new myproj servant - $ cd myproj - # build - $ stack build - # start server - $ stack exec myproj-exe - -The code can be found in the `*.lhs` files under `doc/tutorial/` in the -repository. Feel free to edit it while you're reading this documentation and -see the effect of your changes. - -`Nix `_ users should feel free to take a look at -the `nix/shell.nix` file in the repository and use it to provision a suitable -environment to build and run the examples. - .. toctree:: :maxdepth: 1 + install.rst ApiType.lhs Server.lhs Client.lhs diff --git a/doc/tutorial/install.rst b/doc/tutorial/install.rst new file mode 100644 index 00000000..e0d1a70d --- /dev/null +++ b/doc/tutorial/install.rst @@ -0,0 +1,42 @@ +Install +======== + +cabal-install +-------- + +The whole tutorial is a `cabal `_ +project and can be built locally as follows: + +.. code-block:: bash + + $ git clone https://github.com/haskell-servant/servant.git + $ cd servant + # build + $ cabal new-build tutorial + # load in ghci to play with it + $ cabal new-repl tutorial + +stack +-------- + +The servant `stack `_ template includes the working tutorial. To initialize this template, run: + +.. code-block:: bash + + $ stack new myproj servant + $ cd myproj + # build + $ stack build + # start server + $ stack exec myproj-exe + +The code can be found in the `*.lhs` files under `doc/tutorial/` in the +repository. Feel free to edit it while you're reading this documentation and +see the effect of your changes. + +nix +-------- + +`Nix `_ users should feel free to take a look at +the `nix/shell.nix` file in the repository and use it to provision a suitable +environment to build and run the examples. diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index ce245b65..a2844e9e 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -6,18 +6,15 @@ description: homepage: http://docs.servant.dev/ category: Servant, Documentation -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 tested-with: - GHC==8.0.2 - GHC==8.2.2 - GHC==8.4.4 GHC==8.6.5 - GHC==8.8.1 + GHC==8.8.3, GHC ==8.10.7 extra-source-files: static/index.html static/ui.js @@ -68,9 +65,9 @@ library , cookie >= 0.4.3 && < 0.5 , js-jquery >= 3.3.1 && < 3.4 , lucid >= 2.9.11 && < 2.10 - , random >= 1.1 && < 1.2 + , random >= 1.1 && < 1.3 , servant-js >= 0.9 && < 0.10 - , time >= 1.6.0.1 && < 1.10 + , time >= 1.6.0.1 && < 1.13 -- For legacy tools, we need to specify build-depends too build-depends: markdown-unlit >= 0.5.0 && <0.6 diff --git a/ghcjs.nix b/ghcjs.nix new file mode 100644 index 00000000..274d007c --- /dev/null +++ b/ghcjs.nix @@ -0,0 +1,22 @@ +let reflex-platform = import (builtins.fetchTarball + { name = "reflex-platform"; + url = "https://github.com/reflex-frp/reflex-platform/archive/1aba6f367982bd6dd78ec2fda75ab246a62d32c5.tar.gz"; + }) {}; + pkgs = import ./nix/nixpkgs.nix; in + +pkgs.stdenv.mkDerivation { + name = "ghcjs-shell"; + buildInputs = + [ (reflex-platform.ghcjs.ghcWithPackages (p: with p; [ + attoparsec + hashable + ])) + pkgs.cabal-install + pkgs.gmp + pkgs.haskellPackages.cabal-plan + pkgs.haskellPackages.hspec-discover + pkgs.nodejs + pkgs.perl + pkgs.zlib + ]; +} diff --git a/nix/README.md b/nix/README.md index 56400fbd..f865a383 100644 --- a/nix/README.md +++ b/nix/README.md @@ -21,3 +21,21 @@ a particular ghc version, e.g: ``` sh $ nix-shell nix/shell.nix --argstr compiler ghcHEAD ``` + +**Possible GHC versions** +- `ghc865Binary` +- `ghc884` +- `ghc8104` - default +- `ghc901` + +### Cabal users + +GHC version can be chosen via the nix-shell parameter + +`cabal build all` + +### Stack version + +Since the ghc version is set by the LTS version, it is preferable to use the `ghc8104` version parameter for the nix-shell. + +`stack --no-nix --system-ghc ` \ No newline at end of file diff --git a/nix/nixpkgs.json b/nix/nixpkgs.json new file mode 100644 index 00000000..b6bf5f32 --- /dev/null +++ b/nix/nixpkgs.json @@ -0,0 +1,4 @@ +{ + "rev" : "05f0934825c2a0750d4888c4735f9420c906b388", + "sha256" : "1g8c2w0661qn89ajp44znmwfmghbbiygvdzq0rzlvlpdiz28v6gy" +} diff --git a/nix/nixpkgs.nix b/nix/nixpkgs.nix new file mode 100644 index 00000000..744f982c --- /dev/null +++ b/nix/nixpkgs.nix @@ -0,0 +1,4 @@ +import (builtins.fetchTarball { + url = "https://github.com/NixOS/nixpkgs/archive/refs/tags/21.05.tar.gz"; + sha256 = "sha256:1ckzhh24mgz6jd1xhfgx0i9mijk6xjqxwsshnvq789xsavrmsc36"; +}) {} diff --git a/nix/shell.nix b/nix/shell.nix index 4e43c606..d178b60e 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -1,21 +1,20 @@ -{ pkgs ? import {} -, compiler ? "ghc822" +{ compiler ? "ghc8104" , tutorial ? false +, pkgs ? import ./nixpkgs.nix }: + + with pkgs; -with pkgs; - -let - ghc = haskell.packages.${compiler}.ghcWithPackages (_: []); - docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]); -in - -stdenv.mkDerivation { - name = "servant-dev"; - buildInputs = [ ghc zlib python3 wget ] - ++ (if tutorial then [docstuffs postgresql] else []); - shellHook = '' - eval $(grep export ${ghc}/bin/ghc) - export LD_LIBRARY_PATH="${zlib}/lib"; - ''; -} + let + ghc = haskell.packages.${compiler}.ghcWithPackages (_: []); + docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]); + in + stdenv.mkDerivation { + name = "servant-dev"; + buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl stack haskellPackages.hspec-discover ] + ++ (if tutorial then [docstuffs postgresql] else []); + shellHook = '' + eval $(grep export ${ghc}/bin/ghc) + export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:"${zlib}/lib"; + ''; + } diff --git a/servant-auth/README.md b/servant-auth/README.md new file mode 120000 index 00000000..2cc807b6 --- /dev/null +++ b/servant-auth/README.md @@ -0,0 +1 @@ +servant-auth-server/README.lhs \ No newline at end of file diff --git a/servant-auth/servant-auth-client/.ghci b/servant-auth/servant-auth-client/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-client/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-client/CHANGELOG.md b/servant-auth/servant-auth-client/CHANGELOG.md new file mode 100644 index 00000000..2ce9f585 --- /dev/null +++ b/servant-auth/servant-auth-client/CHANGELOG.md @@ -0,0 +1,26 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) +and this project adheres to [PVP Versioning](https://pvp.haskell.org/). + +## [Unreleased] + +## [0.4.1.0] - 2020-10-06 + +- Support generic Bearer token auth + +## [0.4.0.0] - 2019-03-08 + +## Changed + +- #145 Support servant-0.16 in tests @domenkozar +- #145 Drop GHC 7.10 support @domenkozar + +## [0.3.3.0] - 2018-06-18 + +### Added +- Support for GHC 8.4 by @phadej +- Support for servant-0.14 by @phadej +- Changelog by @domenkozar diff --git a/servant-auth/servant-auth-client/LICENSE b/servant-auth/servant-auth-client/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth-client/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/servant-auth/servant-auth-client/Setup.hs b/servant-auth/servant-auth-client/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth-client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth-client/servant-auth-client.cabal b/servant-auth/servant-auth-client/servant-auth-client.cabal new file mode 100644 index 00000000..20e33af6 --- /dev/null +++ b/servant-auth/servant-auth-client/servant-auth-client.cabal @@ -0,0 +1,80 @@ +name: servant-auth-client +version: 0.4.1.0 +synopsis: servant-client/servant-auth compatibility +description: This package provides instances that allow generating clients from + + APIs that use + @Auth@ combinator. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/haskell-servant/servant + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.10 && < 4.16 + , bytestring >= 0.10.6.0 && < 0.11 + , containers >= 0.5.6.2 && < 0.7 + , servant-auth == 0.4.* + , servant >= 0.13 && < 0.19 + , servant-client-core >= 0.13 && < 0.19 + + exposed-modules: + Servant.Auth.Client + Servant.Auth.Client.Internal + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9 + + -- dependencies with bounds inherited from the library stanza + build-depends: + base + , servant-client + , servant-auth + , servant + , servant-auth-client + + -- test dependencies + build-depends: + hspec >= 2.5.5 && < 2.9 + , QuickCheck >= 2.11.3 && < 2.15 + , aeson >= 1.3.1.1 && < 1.6 + , bytestring >= 0.10.6.0 && < 0.11 + , http-client >= 0.5.13.1 && < 0.8 + , http-types >= 0.12.2 && < 0.13 + , servant-auth-server >= 0.4.2.0 && < 0.5 + , servant-server >= 0.13 && < 0.19 + , time >= 1.5.0.1 && < 1.13 + , transformers >= 0.4.2.0 && < 0.6 + , wai >= 3.2.1.2 && < 3.3 + , warp >= 3.2.25 && < 3.4 + , jose >= 0.7.0.0 && < 0.9 + other-modules: + Servant.Auth.ClientSpec + default-language: Haskell2010 diff --git a/servant-auth/servant-auth-client/src/Servant/Auth/Client.hs b/servant-auth/servant-auth-client/src/Servant/Auth/Client.hs new file mode 100644 index 00000000..71e1ad89 --- /dev/null +++ b/servant-auth/servant-auth-client/src/Servant/Auth/Client.hs @@ -0,0 +1,3 @@ +module Servant.Auth.Client (Token(..), Bearer) where + +import Servant.Auth.Client.Internal (Bearer, Token(..)) diff --git a/servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs b/servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs new file mode 100644 index 00000000..4cdc9dd9 --- /dev/null +++ b/servant-auth/servant-auth-client/src/Servant/Auth/Client/Internal.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +#if __GLASGOW_HASKELL__ == 800 +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +#endif +module Servant.Auth.Client.Internal where + +import qualified Data.ByteString as BS +import Data.Monoid +import Data.Proxy (Proxy (..)) +import Data.String (IsString) +import GHC.Exts (Constraint) +import GHC.Generics (Generic) +import Servant.API ((:>)) +import Servant.Auth + +import Servant.Client.Core +import Data.Sequence ((<|)) + +-- | A simple bearer token. +newtype Token = Token { getToken :: BS.ByteString } + deriving (Eq, Show, Read, Generic, IsString) + +type family HasBearer xs :: Constraint where + HasBearer (Bearer ': xs) = () + HasBearer (JWT ': xs) = () + HasBearer (x ': xs) = HasBearer xs + HasBearer '[] = BearerAuthNotEnabled + +class BearerAuthNotEnabled + +-- | @'HasBearer' auths@ is nominally a redundant constraint, but ensures we're not +-- trying to send a token to an API that doesn't accept them. +instance (HasBearer auths, HasClient m api) => HasClient m (Auth auths a :> api) where + type Client m (Auth auths a :> api) = Token -> Client m api + + clientWithRoute m _ req (Token token) + = clientWithRoute m (Proxy :: Proxy api) + $ req { requestHeaders = ("Authorization", headerVal) <| requestHeaders req } + where + headerVal = "Bearer " <> token + +#if MIN_VERSION_servant_client_core(0,14,0) + hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl +#endif + + +-- * Authentication combinators + +-- | A Bearer token in the Authorization header: +-- +-- @Authorization: Bearer @ +-- +-- This can be any token recognized by the server, for example, +-- a JSON Web Token (JWT). +-- +-- Note that, since the exact way the token is validated is not specified, +-- this combinator can only be used in the client. The server would not know +-- how to validate it, while the client does not care. +-- If you want to implement Bearer authentication in your server, you have to +-- choose a specific combinator, such as 'JWT'. +data Bearer diff --git a/servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs b/servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs new file mode 100644 index 00000000..fdd22ab2 --- /dev/null +++ b/servant-auth/servant-auth-client/test/Servant/Auth/ClientSpec.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveAnyClass #-} +module Servant.Auth.ClientSpec (spec) where + +import Crypto.JOSE (JWK, + KeyMaterialGenParam (OctGenParam), + genJWK) +import Data.Aeson (FromJSON (..), ToJSON (..)) +import qualified Data.ByteString.Lazy as BSL +import Data.Time (UTCTime, defaultTimeLocale, + parseTimeOrError) +import GHC.Generics (Generic) +import Network.HTTP.Client (Manager, defaultManagerSettings, + newManager) +import Network.HTTP.Types (status401) +import Network.Wai.Handler.Warp (testWithApplication) +import Servant +import Servant.Client (BaseUrl (..), Scheme (Http), + ClientError (FailureResponse), +#if MIN_VERSION_servant_client(0,16,0) + ResponseF(..), +#elif MIN_VERSION_servant_client(0,13,0) + GenResponse(..), +#elif MIN_VERSION_servant_client(0,12,0) + Response(..), +#endif + client) +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec +import Test.QuickCheck + +#if MIN_VERSION_servant_client(0,13,0) +import Servant.Client (mkClientEnv, runClientM) +#elif MIN_VERSION_servant_client(0,9,0) +import Servant.Client (ClientEnv (..), runClientM) +#else +import Control.Monad.Trans.Except (runExceptT) +#endif +#if !MIN_VERSION_servant_server(0,16,0) +#define ClientError ServantError +#endif + +import Servant.Auth.Client +import Servant.Auth.Server +import Servant.Auth.Server.SetCookieOrphan () + +spec :: Spec +spec = describe "The JWT combinator" $ do + hasClientSpec + + +------------------------------------------------------------------------------ +-- * HasClient {{{ + +hasClientSpec :: Spec +hasClientSpec = describe "HasClient" $ around (testWithApplication $ return app) $ do + + let mkTok :: User -> Maybe UTCTime -> IO Token + mkTok user mexp = do + Right tok <- makeJWT user jwtCfg mexp + return $ Token $ BSL.toStrict tok + + it "succeeds when the token does not have expiry" $ \port -> property $ \user -> do + tok <- mkTok user Nothing + v <- getIntClient tok mgr (BaseUrl Http "localhost" port "") + v `shouldBe` Right (length $ name user) + + it "succeeds when the token is not expired" $ \port -> property $ \user -> do + tok <- mkTok user (Just future) + v <- getIntClient tok mgr (BaseUrl Http "localhost" port "") + v `shouldBe` Right (length $ name user) + + it "fails when token is expired" $ \port -> property $ \user -> do + tok <- mkTok user (Just past) +#if MIN_VERSION_servant_client(0,16,0) + Left (FailureResponse _ (Response stat _ _ _)) +#elif MIN_VERSION_servant_client(0,12,0) + Left (FailureResponse (Response stat _ _ _)) +#elif MIN_VERSION_servant_client(0,11,0) + Left (FailureResponse _ stat _ _) +#else + Left (FailureResponse stat _ _) +#endif + <- getIntClient tok mgr (BaseUrl Http "localhost" port "") + stat `shouldBe` status401 + + +getIntClient :: Token -> Manager -> BaseUrl -> IO (Either ClientError Int) +#if MIN_VERSION_servant(0,13,0) +getIntClient tok m burl = runClientM (client api tok) (mkClientEnv m burl) +#elif MIN_VERSION_servant(0,9,0) +getIntClient tok m burl = runClientM (client api tok) (ClientEnv m burl) +#else +getIntClient tok m burl = runExceptT $ client api tok m burl +#endif +-- }}} +------------------------------------------------------------------------------ +-- * API and Server {{{ + +type API = Auth '[JWT] User :> Get '[JSON] Int + +api :: Proxy API +api = Proxy + +theKey :: JWK +theKey = unsafePerformIO . genJWK $ OctGenParam 256 +{-# NOINLINE theKey #-} + +mgr :: Manager +mgr = unsafePerformIO $ newManager defaultManagerSettings +{-# NOINLINE mgr #-} + +app :: Application +app = serveWithContext api ctx server + where + ctx = cookieCfg :. jwtCfg :. EmptyContext + +jwtCfg :: JWTSettings +jwtCfg = defaultJWTSettings theKey + +cookieCfg :: CookieSettings +cookieCfg = defaultCookieSettings + + +server :: Server API +server = getInt + where + getInt :: AuthResult User -> Handler Int + getInt (Authenticated u) = return . length $ name u + getInt _ = throwAll err401 + + +-- }}} +------------------------------------------------------------------------------ +-- * Utils {{{ + +past :: UTCTime +past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01" + +future :: UTCTime +future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01" + + +-- }}} +------------------------------------------------------------------------------ +-- * Types {{{ + +data User = User + { name :: String + , _id :: String + } deriving (Eq, Show, Read, Generic) + +instance FromJWT User +instance ToJWT User +instance FromJSON User +instance ToJSON User + +instance Arbitrary User where + arbitrary = User <$> arbitrary <*> arbitrary + +-- }}} diff --git a/servant-auth/servant-auth-client/test/Spec.hs b/servant-auth/servant-auth-client/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-client/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth-docs/.ghci b/servant-auth/servant-auth-docs/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-docs/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-docs/CHANGELOG.md b/servant-auth/servant-auth-docs/CHANGELOG.md new file mode 100644 index 00000000..0a255fb1 --- /dev/null +++ b/servant-auth/servant-auth-docs/CHANGELOG.md @@ -0,0 +1,14 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) +and this project adheres to [PVP Versioning](https://pvp.haskell.org/). + +## [Unreleased] + +## [0.2.10.0] - 2018-06-18 + +### Added +- Support for GHC 8.4 by @phadej +- Changelog by @domenkozar diff --git a/servant-auth/servant-auth-docs/LICENSE b/servant-auth/servant-auth-docs/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth-docs/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/servant-auth/servant-auth-docs/Setup.hs b/servant-auth/servant-auth-docs/Setup.hs new file mode 100644 index 00000000..8ec54a08 --- /dev/null +++ b/servant-auth/servant-auth-docs/Setup.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + +import Distribution.Simple + +main :: IO () +main = defaultMain + +#endif diff --git a/servant-auth/servant-auth-docs/servant-auth-docs.cabal b/servant-auth/servant-auth-docs/servant-auth-docs.cabal new file mode 100644 index 00000000..10453fc0 --- /dev/null +++ b/servant-auth/servant-auth-docs/servant-auth-docs.cabal @@ -0,0 +1,84 @@ +name: servant-auth-docs +version: 0.2.10.0 +synopsis: servant-docs/servant-auth compatibility +description: This package provides instances that allow generating docs from + + APIs that use + @Auth@ combinator. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 +build-type: Custom +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + +custom-setup + setup-depends: + base, Cabal, cabal-doctest >=1.0.6 && <1.1 + +source-repository head + type: git + location: https://github.com/haskell-servant/servant + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.10 && < 4.16 + , servant-docs >= 0.11.2 && < 0.12 + , servant >= 0.13 && < 0.19 + , servant-auth == 0.4.* + , lens >= 4.16.1 && <5.1 + exposed-modules: + Servant.Auth.Docs + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + build-depends: + base, + servant-auth-docs, + doctest >= 0.16 && < 0.19, + QuickCheck >= 2.11.3 && < 2.15, + template-haskell + ghc-options: -Wall -threaded + hs-source-dirs: test + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.9 + + -- dependencies with bounds inherited from the library stanza + build-depends: + base + , text + , servant-docs + , servant + , servant-auth + , lens + + -- test dependencies + build-depends: + servant-auth-docs + , hspec >= 2.5.5 && < 2.9 + , QuickCheck >= 2.11.3 && < 2.15 + + default-language: Haskell2010 diff --git a/servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs b/servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs new file mode 100644 index 00000000..da507990 --- /dev/null +++ b/servant-auth/servant-auth-docs/src/Servant/Auth/Docs.hs @@ -0,0 +1,96 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Servant.Auth.Docs + ( + -- | The purpose of this package is provide the instance for 'servant-auth' + -- combinators needed for 'servant-docs' documentation generation. + -- + -- >>> type API = Auth '[JWT, Cookie, BasicAuth] Int :> Get '[JSON] Int + -- >>> putStr $ markdown $ docs (Proxy :: Proxy API) + -- ## GET / + -- ... + -- ... Authentication + -- ... + -- This part of the API is protected by the following authentication mechanisms: + -- ... + -- * JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token)) + -- * [Cookies](https://en.wikipedia.org/wiki/HTTP_cookie) + -- * [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication) + -- ... + -- Clients must supply the following data + -- ... + -- One of the following: + -- ... + -- * A JWT Token signed with this server's key + -- * Cookies automatically set by browsers, plus a header + -- * Cookies automatically set by browsers, plus a header + -- ... + + -- * Re-export + JWT + , BasicAuth + , Cookie + , Auth + ) where + +import Control.Lens ((%~), (&), (|>)) +import Data.List (intercalate) +import Data.Monoid +import Data.Proxy (Proxy (Proxy)) +import Servant.API hiding (BasicAuth) +import Servant.Auth +import Servant.Docs hiding (pretty) +import Servant.Docs.Internal (DocAuthentication (..), authInfo) + +instance (AllDocs auths, HasDocs api) => HasDocs (Auth auths r :> api) where + docsFor _ (endpoint, action) = + docsFor (Proxy :: Proxy api) (endpoint, action & authInfo %~ (|> info)) + where + (intro, reqData) = pretty $ allDocs (Proxy :: Proxy auths) + info = DocAuthentication intro reqData + + +pretty :: [(String, String)] -> (String, String) +pretty [] = error "shouldn't happen" +pretty [(i, d)] = + ( "This part of the API is protected by " <> i + , d + ) +pretty rs = + ( "This part of the API is protected by the following authentication mechanisms:\n\n" + ++ " * " <> intercalate "\n * " (fst <$> rs) + , "\nOne of the following:\n\n" + ++ " * " <> intercalate "\n * " (snd <$> rs) + ) + + +class AllDocs (x :: [*]) where + allDocs :: proxy x + -- intro, req + -> [(String, String)] + +instance (OneDoc a, AllDocs as) => AllDocs (a ': as) where + allDocs _ = oneDoc (Proxy :: Proxy a) : allDocs (Proxy :: Proxy as) + +instance AllDocs '[] where + allDocs _ = [] + +class OneDoc a where + oneDoc :: proxy a -> (String, String) + +instance OneDoc JWT where + oneDoc _ = + ("JSON Web Tokens ([JWTs](https://en.wikipedia.org/wiki/JSON_Web_Token))" + , "A JWT Token signed with this server's key") + +instance OneDoc Cookie where + oneDoc _ = + ("[Cookies](https://en.wikipedia.org/wiki/HTTP_cookie)" + , "Cookies automatically set by browsers, plus a header") + +instance OneDoc BasicAuth where + oneDoc _ = + ( "[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)" + , "Cookies automatically set by browsers, plus a header") + +-- $setup +-- >>> instance ToSample Int where toSamples _ = singleSample 1729 diff --git a/servant-auth/servant-auth-docs/test/Spec.hs b/servant-auth/servant-auth-docs/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-docs/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth-docs/test/doctests.hs b/servant-auth/servant-auth-docs/test/doctests.hs new file mode 100644 index 00000000..aff961f5 --- /dev/null +++ b/servant-auth/servant-auth-docs/test/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources diff --git a/servant-auth/servant-auth-server/.ghci b/servant-auth/servant-auth-server/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-server/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-server/CHANGELOG.md b/servant-auth/servant-auth-server/CHANGELOG.md new file mode 100644 index 00000000..34b137d2 --- /dev/null +++ b/servant-auth/servant-auth-server/CHANGELOG.md @@ -0,0 +1,130 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) +and this project adheres to [PVP Versioning](https://pvp.haskell.org/). + +## [Unreleased] + +## [0.4.6.0] - 2020-10-06 + +## Changed + +- expose verifyJWT and use it in two places [@domenkozar] +- support GHC 8.10 [@domenkozar] +- move ToJWT/FromJWT to servant-auth [@erewok] +- #165 fix AnySite with Cookie 3.5.0 [@odr] + +## [0.4.5.1] - 2020-02-06 + +## Changed + +- #158 servant 0.17 support [@phadej] + +## [0.4.5.0] - 2019-12-28 + +## Changed +- #144 servant 0.16 support and drop GHC 7.10 support [@domenkozar] +- #148 removed unused constaint in HasServer instance for Auth +- #154 GHC 8.8 support [@phadej] + +### Added +- #141 Support Stream combinator [@domenkozar] +- #143 Allow servant-0.16 [@phadej] + +## [0.4.4.0] - 2019-03-02 + +### Added +- #141 Support Stream combinator [@domenkozar] +- #143 Allow servant-0.16 [@phadej] + +## [0.4.3.0] - 2019-01-17 + +## Changed +- #117 Avoid running auth checks unnecessarily [@sopvop] +- #110 Get rid of crypto-api dependency [@domenkozar] +- #130 clearSession: improve cross-browser compatibility [@domenkozar] +- #136 weed out bytestring-conversion [@stephenirl] + +## [0.4.2.0] - 2018-11-05 + +### Added +- `Headers hs a` instance for AddSetCookieApi [@domenkozar] +- GHC 8.6.x support [@domenkozar] + +## [0.4.1.0] - 2018-10-05 + +### Added +- #125 Allow setting domain name for a cookie [@domenkozar] + +## Changed +- bump http-api-data to 0.3.10 that includes Cookie orphan instances previously located in servant-auth-server [@phadej] +- #114 Export `HasSecurity` typeclass [@rockbmb] + +## [0.4.0.1] - 2018-09-23 + +### Security +- #123 Session cookie did not apply SameSite attribute [@domenkozar] + +### Added +- #112 HasLink instance for Auth combinator [@adetokunbo] +- #111 Documentation for using hoistServer [@mschristiansen] +- #107 Add utility functions for reading and writing a key to a file [@mschristiansen] + +## [0.4.0.0] - 2018-06-17 + +### Added +- Support GHC 8.4 by @phadej and @domenkozar +- Support for servant-0.14 by @phadej +- #96 Support for jose-0.7 by @xaviershay +- #92 add `clearSession` for logout by @plredmond and @3noch +- #95 makeJWT: allow setting Alg via defaultJWTSettings by @domenkozar +- #89 Validate JWT against a JWKSet instead of JWK by @sopvop + +### Changed +- #92 Rename CSRF to XSRF by @plredmond and @3noch +- #92 extract 'XsrfCookieSettings' from 'CookieSettings' and make XSRF checking optional + by @plredmond and @3noch +- #69 export SameSite by @domenkozar +- #102 Reuse Servant.Api.IsSecure instead of duplicating ADT by @domenkozar + +### Deprecated +- #92 Renamed 'makeCsrfCookie' to 'makeXsrfCookie' and marked the former as deprecated + by @plredmond and @3noc +- #92 Made several changes to the structure of 'CookieSettings' which will require + attention by users who have modified the XSRF settings by @plredmond and @3noch + +### Security +- #94 Force cookie expiration on serverside by @karshan + +## [0.3.2.0] - 2018-02-21 + +### Added +- #76 Export wwwAuthenticatedErr and elaborate its annotation by @defanor +- Support for servant-0.14 by @phadej + +### Changed +- Disable the readme executable for ghcjs builds by @hamishmack +- #84 Make AddSetCookieApi type family open by @qnikst +- #79 Make CSRF checks optional for GET requests by @harendra-kumar + +## [0.3.1.0] - 2017-11-08 + +### Added +- Support for servant-0.12 by @phadej + +## [0.3.0.0] - 2017-11-07 + +### Changed +- #47 'cookiePath' and 'xsrfCookiePath' added to 'CookieSettings' by @mchaver + +## [0.2.8.0] - 2017-05-26 + +### Added +- #45 Support for servant-0.11 by @phadej + +## [0.2.7.0] - 2017-02-11 + +### Changed +- #27 #41 'acceptLogin' and 'makeCsrfCookie' functions by @bts diff --git a/servant-auth/servant-auth-server/LICENSE b/servant-auth/servant-auth-server/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth-server/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/servant-auth/servant-auth-server/README.lhs b/servant-auth/servant-auth-server/README.lhs new file mode 100644 index 00000000..27259465 --- /dev/null +++ b/servant-auth/servant-auth-server/README.lhs @@ -0,0 +1,291 @@ +# servant-auth + +These packages provides safe and easy-to-use authentication options for +`servant`. The same API can be protected via: +- basicauth +- cookies +- JWT tokens + + +| Package | Hackage | +| -------------------- | ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- | +| servant-auth | [![servant-auth](https://img.shields.io/hackage/v/servant-auth?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth) | +| servant-auth-server | [![servant-auth-server](https://img.shields.io/hackage/v/servant-auth-server.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-server) | +| servant-auth-client | [![servant-auth-client](https://img.shields.io/hackage/v/servant-auth-client.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-client) | +| servant-auth-swagger | [![servant-auth-swagger](https://img.shields.io/hackage/v/servant-auth-swagger.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-swagger) | +| servant-auth-docs | [![servant-auth-docs](https://img.shields.io/hackage/v/servant-auth-docs.svg?style=flat-square&logo=haskell&label&labelColor=5D4F85)](https://hackage.haskell.org/package/servant-auth-docs) | + +## How it works + +First some imports: + +~~~ haskell +{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +import Control.Concurrent (forkIO) +import Control.Monad (forever) +import Control.Monad.Trans (liftIO) +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Network.Wai.Handler.Warp (run) +import System.Environment (getArgs) +import Servant +import Servant.Auth.Server +import Servant.Auth.Server.SetCookieOrphan () +~~~ + +`servant-auth` library introduces a combinator `Auth`: + +~~~ haskell +data Auth (auths :: [*]) val +~~~ + +What `Auth [Auth1, Auth2] Something :> API` means is that `API` is protected by +*either* `Auth1` *or* `Auth2`, and the result of authentication will be of type +`AuthResult Something`, where : + +~~~ haskell +data AuthResult val + = BadPassword + | NoSuchUser + | Authenticated val + | Indefinite +~~~ + +Your handlers will get a value of type `AuthResult Something`, and can decide +what to do with it. + +~~~ haskell + +data User = User { name :: String, email :: String } + deriving (Eq, Show, Read, Generic) + +instance ToJSON User +instance ToJWT User +instance FromJSON User +instance FromJWT User + +data Login = Login { username :: String, password :: String } + deriving (Eq, Show, Read, Generic) + +instance ToJSON Login +instance FromJSON Login + +type Protected + = "name" :> Get '[JSON] String + :<|> "email" :> Get '[JSON] String + + +-- | 'Protected' will be protected by 'auths', which we still have to specify. +protected :: Servant.Auth.Server.AuthResult User -> Server Protected +-- If we get an "Authenticated v", we can trust the information in v, since +-- it was signed by a key we trust. +protected (Servant.Auth.Server.Authenticated user) = return (name user) :<|> return (email user) +-- Otherwise, we return a 401. +protected _ = throwAll err401 + +type Unprotected = + "login" + :> ReqBody '[JSON] Login + :> Verb 'POST 204 '[JSON] (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) + :<|> Raw + +unprotected :: CookieSettings -> JWTSettings -> Server Unprotected +unprotected cs jwts = checkCreds cs jwts :<|> serveDirectory "example/static" + +type API auths = (Servant.Auth.Server.Auth auths User :> Protected) :<|> Unprotected + +server :: CookieSettings -> JWTSettings -> Server (API auths) +server cs jwts = protected :<|> unprotected cs jwts + +~~~ + +The code is common to all authentications. In order to pick one or more specific +authentication methods, all we need to do is provide the expect configuration +parameters. + +## API tokens + +The following example illustrates how to protect an API with tokens. + + +~~~ haskell +-- In main, we fork the server, and allow new tokens to be created in the +-- command line for the specified user name and email. +mainWithJWT :: IO () +mainWithJWT = do + -- We generate the key for signing tokens. This would generally be persisted, + -- and kept safely + myKey <- generateKey + -- Adding some configurations. All authentications require CookieSettings to + -- be in the context. + let jwtCfg = defaultJWTSettings myKey + cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + --- Here we actually make concrete + api = Proxy :: Proxy (API '[JWT]) + _ <- forkIO $ run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) + + putStrLn "Started server on localhost:7249" + putStrLn "Enter name and email separated by a space for a new token" + + forever $ do + xs <- words <$> getLine + case xs of + [name', email'] -> do + etoken <- makeJWT (User name' email') jwtCfg Nothing + case etoken of + Left e -> putStrLn $ "Error generating token:t" ++ show e + Right v -> putStrLn $ "New token:\t" ++ show v + _ -> putStrLn "Expecting a name and email separated by spaces" + +~~~ + +And indeed: + +~~~ bash + +./readme JWT + + Started server on localhost:7249 + Enter name and email separated by a space for a new token + alice alice@gmail.com + New token: "eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" + +curl localhost:7249/name -v + + * Hostname was NOT found in DNS cache + * Trying 127.0.0.1... + * Connected to localhost (127.0.0.1) port 7249 (#0) + > GET /name HTTP/1.1 + > User-Agent: curl/7.35.0 + > Host: localhost:7249 + > Accept: */* + > + < HTTP/1.1 401 Unauthorized + < Transfer-Encoding: chunked + < Date: Wed, 07 Sep 2016 20:17:17 GMT + * Server Warp/3.2.7 is not blacklisted + < Server: Warp/3.2.7 + < + * Connection #0 to host localhost left intact + +curl -H "Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE" \ + localhost:7249/name -v + + * Hostname was NOT found in DNS cache + * Trying 127.0.0.1... + * Connected to localhost (127.0.0.1) port 7249 (#0) + > GET /name HTTP/1.1 + > User-Agent: curl/7.35.0 + > Host: localhost:7249 + > Accept: */* + > Authorization: Bearer eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE + > + < HTTP/1.1 200 OK + < Transfer-Encoding: chunked + < Date: Wed, 07 Sep 2016 20:16:11 GMT + * Server Warp/3.2.7 is not blacklisted + < Server: Warp/3.2.7 + < Content-Type: application/json + < Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzI1NiJ9.eyJkYXQiOnsiZW1haWwiOiJhbGljZUBnbWFpbC5jb20iLCJuYW1lIjoiYWxpY2UifX0.xzOIrx_A9VOKzVO-R1c1JYKBqK9risF625HOxpBzpzE; HttpOnly; Secure + < Set-Cookie: XSRF-TOKEN=TWcdPnHr2QHcVyTw/TTBLQ==; Secure + < + * Connection #0 to host localhost left intact + "alice"% + + +~~~ + +## Cookies + +What if, in addition to API tokens, we want to expose our API to browsers? All +we need to do is say so! + +~~~ haskell +mainWithCookies :: IO () +mainWithCookies = do + -- We *also* need a key to sign the cookies + myKey <- generateKey + -- Adding some configurations. 'Cookie' requires, in addition to + -- CookieSettings, JWTSettings (for signing), so everything is just as before + let jwtCfg = defaultJWTSettings myKey + cfg = defaultCookieSettings :. jwtCfg :. EmptyContext + --- Here is the actual change + api = Proxy :: Proxy (API '[Cookie]) + run 7249 $ serveWithContext api cfg (server defaultCookieSettings jwtCfg) + +-- Here is the login handler +checkCreds :: CookieSettings + -> JWTSettings + -> Login + -> Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie] + NoContent) +checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do + -- Usually you would ask a database for the user info. This is just a + -- regular servant handler, so you can follow your normal database access + -- patterns (including using 'enter'). + let usr = User "Ali Baba" "ali@email.com" + mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr + case mApplyCookies of + Nothing -> throwError err401 + Just applyCookies -> return $ applyCookies NoContent +checkCreds _ _ _ = throwError err401 +~~~ + +### XSRF and the frontend + +XSRF protection works by requiring that there be a header of the same value as +a distinguished cookie that is set by the server on each request. What the +cookie and header name are can be configured (see `xsrfCookieName` and +`xsrfHeaderName` in `CookieSettings`), but by default they are "XSRF-TOKEN" and +"X-XSRF-TOKEN". This means that, if your client is a browser and you're using +cookies, Javascript on the client must set the header of each request by +reading the cookie. For jQuery, and with the default values, that might be: + +~~~ javascript + +var token = (function() { + r = document.cookie.match(new RegExp('XSRF-TOKEN=([^;]+)')) + if (r) return r[1]; +})(); + + +$.ajaxPrefilter(function(opts, origOpts, xhr) { + xhr.setRequestHeader('X-XSRF-TOKEN', token); + } + +~~~ + +I *believe* nothing at all needs to be done if you're using Angular's `$http` +directive, but I haven't tested this. + +XSRF protection can be disabled just for `GET` requests by setting +`xsrfExcludeGet = False`. You might want this if you're relying on the browser +to navigate between pages that require cookie authentication. + +XSRF protection can be completely disabled by setting `cookieXsrfSetting = +Nothing` in `CookieSettings`. This is not recommended! If your cookie +authenticated web application runs any javascript, it's recommended to send the +XSRF header. However, if your web application runs no javascript, disabling +XSRF entirely may be required. + +# Note on this README + +This README is a literate haskell file. Here is 'main', allowing you to pick +between the examples above. + +~~~ haskell + +main :: IO () +main = do + args <- getArgs + let usage = "Usage: readme (JWT|Cookie)" + case args of + ["JWT"] -> mainWithJWT + ["Cookie"] -> mainWithCookies + e -> putStrLn $ "Arguments: \"" ++ unwords e ++ "\" not understood\n" ++ usage + +~~~ diff --git a/servant-auth/servant-auth-server/README.md b/servant-auth/servant-auth-server/README.md new file mode 120000 index 00000000..4e381b2e --- /dev/null +++ b/servant-auth/servant-auth-server/README.md @@ -0,0 +1 @@ +README.lhs \ No newline at end of file diff --git a/servant-auth/servant-auth-server/Setup.hs b/servant-auth/servant-auth-server/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth-server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth-server/servant-auth-server.cabal b/servant-auth/servant-auth-server/servant-auth-server.cabal new file mode 100644 index 00000000..a58e5364 --- /dev/null +++ b/servant-auth/servant-auth-server/servant-auth-server.cabal @@ -0,0 +1,134 @@ +name: servant-auth-server +version: 0.4.6.0 +synopsis: servant-server/servant-auth compatibility +description: This package provides the required instances for using the @Auth@ combinator + in your 'servant' server. + . + Both cookie- and token- (REST API) based authentication is provided. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/haskell-servant/servant + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.10 && < 4.16 + , aeson >= 1.3.1.1 && < 1.6 + , base64-bytestring >= 1.0.0.1 && < 1.3 + , blaze-builder >= 0.4.1.0 && < 0.5 + , bytestring >= 0.10.6.0 && < 0.11 + , case-insensitive >= 1.2.0.11 && < 1.3 + , cookie >= 0.4.4 && < 0.5 + , data-default-class >= 0.1.2.0 && < 0.2 + , entropy >= 0.4.1.3 && < 0.5 + , http-types >= 0.12.2 && < 0.13 + , jose >= 0.7.0.0 && < 0.9 + , lens >= 4.16.1 && < 5.1 + , memory >= 0.14.16 && < 0.17 + , monad-time >= 0.3.1.0 && < 0.4 + , mtl >= 2.2.2 && < 2.3 + , servant >= 0.13 && < 0.19 + , servant-auth == 0.4.* + , servant-server >= 0.13 && < 0.19 + , tagged >= 0.8.4 && < 0.9 + , text >= 1.2.3.0 && < 1.3 + , time >= 1.5.0.1 && < 1.10 + , unordered-containers >= 0.2.9.0 && < 0.3 + , wai >= 3.2.1.2 && < 3.3 + + if impl(ghc >= 9) + build-depends: + -- base64-bytestring 1.2.1.0 contains important fix for GHC-9, lower versions + -- produce wrong results, thus corrupring JWT via jose package. + -- See: https://github.com/haskell/base64-bytestring/pull/46 + base64-bytestring >= 1.2.1.0 + + exposed-modules: + Servant.Auth.Server + Servant.Auth.Server.Internal + Servant.Auth.Server.Internal.AddSetCookie + Servant.Auth.Server.Internal.BasicAuth + Servant.Auth.Server.Internal.Class + Servant.Auth.Server.Internal.ConfigTypes + Servant.Auth.Server.Internal.Cookie + Servant.Auth.Server.Internal.FormLogin + Servant.Auth.Server.Internal.JWT + Servant.Auth.Server.Internal.ThrowAll + Servant.Auth.Server.Internal.Types + Servant.Auth.Server.SetCookieOrphan + default-language: Haskell2010 + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit + build-depends: + base + , servant-auth + , servant-auth-server + , servant-server + , aeson + , mtl + , warp + default-language: Haskell2010 + if impl(ghcjs) + buildable: False + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-tool-depends: hspec-discover:hspec-discover >=2.5.5 && <2.8 + + -- dependencies with bounds inherited from the library stanza + build-depends: + base + , aeson + , bytestring + , case-insensitive + , jose + , lens + , mtl + , time + , http-types + , wai + , servant + , servant-server + , transformers + + -- test dependencies + build-depends: + servant-auth-server + , hspec >= 2.5.5 && < 2.8 + , QuickCheck >= 2.11.3 && < 2.15 + , http-client >= 0.5.13.1 && < 0.8 + , lens-aeson >= 1.0.2 && < 1.2 + , warp >= 3.2.25 && < 3.4 + , wreq >= 0.5.2.1 && < 0.6 + other-modules: + Servant.Auth.ServerSpec + default-language: Haskell2010 diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server.hs new file mode 100644 index 00000000..d163fc26 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server.hs @@ -0,0 +1,180 @@ +module Servant.Auth.Server + ( + -- | This package provides implementations for some common authentication + -- methods. Authentication yields a trustworthy (because generated by the + -- server) value of an some arbitrary type: + -- + -- > type MyApi = Protected + -- > + -- > type Protected = Auth '[JWT, Cookie] User :> Get '[JSON] UserAccountDetails + -- > + -- > server :: Server Protected + -- > server (Authenticated usr) = ... -- here we know the client really is + -- > -- who she claims to be + -- > server _ = throwAll err401 + -- + -- Additional configuration happens via 'Context'. + -- + -- == Example for Custom Handler + -- To use a custom 'Servant.Server.Handler' it is necessary to use + -- 'Servant.Server.hoistServerWithContext' instead of + -- 'Servant.Server.hoistServer' and specify the 'Context'. + -- + -- Below is an example of passing 'CookieSettings' and 'JWTSettings' in the + -- 'Context' to create a specialized function equivalent to + -- 'Servant.Server.hoistServer' for an API that includes cookie + -- authentication. + -- + -- > hoistServerWithAuth + -- > :: HasServer api '[CookieSettings, JWTSettings] + -- > => Proxy api + -- > -> (forall x. m x -> n x) + -- > -> ServerT api m + -- > -> ServerT api n + -- > hoistServerWithAuth api = + -- > hoistServerWithContext api (Proxy :: Proxy '[CookieSettings, JWTSettings]) + + ---------------------------------------------------------------------------- + -- * Auth + -- | Basic types + Auth + , AuthResult(..) + , AuthCheck(..) + + ---------------------------------------------------------------------------- + -- * JWT + -- | JSON Web Tokens (JWT) are a compact and secure way of transferring + -- information between parties. In this library, they are signed by the + -- server (or by some other party posessing the relevant key), and used to + -- indicate the bearer's identity or authorization. + -- + -- Arbitrary information can be encoded - just declare instances for the + -- 'FromJWT' and 'ToJWT' classes. Don't go overboard though - be aware that + -- usually you'll be trasmitting this information on each request (and + -- response!). + -- + -- Note that, while the tokens are signed, they are not encrypted. Do not put + -- any information you do not wish the client to know in them! + + -- ** Combinator + -- | Re-exported from 'servant-auth' + , JWT + + -- ** Classes + , FromJWT(..) + , ToJWT(..) + + -- ** Related types + , IsMatch(..) + + -- ** Settings + , JWTSettings(..) + , defaultJWTSettings + + -- ** Create check + , jwtAuthCheck + + + ---------------------------------------------------------------------------- + -- * Cookie + -- | Cookies are also a method of identifying and authenticating a user. They + -- are particular common when the client is a browser + + -- ** Combinator + -- | Re-exported from 'servant-auth' + , Cookie + + -- ** Settings + , CookieSettings(..) + , XsrfCookieSettings(..) + , defaultCookieSettings + , defaultXsrfCookieSettings + , makeSessionCookie + , makeSessionCookieBS + , makeXsrfCookie + , makeCsrfCookie + , makeCookie + , makeCookieBS + , acceptLogin + , clearSession + + + -- ** Related types + , IsSecure(..) + , SameSite(..) + , AreAuths + + ---------------------------------------------------------------------------- + -- * BasicAuth + -- ** Combinator + -- | Re-exported from 'servant-auth' + , BasicAuth + + -- ** Classes + , FromBasicAuthData(..) + + -- ** Settings + , BasicAuthCfg + + -- ** Related types + , BasicAuthData(..) + , IsPasswordCorrect(..) + + -- ** Authentication request + , wwwAuthenticatedErr + + ---------------------------------------------------------------------------- + -- * Utilies + , ThrowAll(throwAll) + , generateKey + , generateSecret + , fromSecret + , writeKey + , readKey + , makeJWT + , verifyJWT + + -- ** Re-exports + , Default(def) + , SetCookie + ) where + +import Prelude hiding (readFile, writeFile) +import Data.ByteString (ByteString, writeFile, readFile) +import Data.Default.Class (Default (def)) +import Servant.Auth +import Servant.Auth.JWT +import Servant.Auth.Server.Internal () +import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.Class +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.JWT +import Servant.Auth.Server.Internal.ThrowAll +import Servant.Auth.Server.Internal.Types + +import Crypto.JOSE as Jose +import Servant (BasicAuthData (..)) +import Web.Cookie (SetCookie) + +-- | Generate a key suitable for use with 'defaultConfig'. +generateKey :: IO Jose.JWK +generateKey = Jose.genJWK $ Jose.OctGenParam 256 + +-- | Generate a bytestring suitable for use with 'fromSecret'. +generateSecret :: MonadRandom m => m ByteString +generateSecret = Jose.getRandomBytes 256 + +-- | Restores a key from a bytestring. +fromSecret :: ByteString -> Jose.JWK +fromSecret = Jose.fromOctets + +-- | Writes a secret to a file. Can for instance be used from the REPL +-- to persist a key to a file, which can then be included with the +-- application. Restore the key using 'readKey'. +writeKey :: FilePath -> IO () +writeKey fp = writeFile fp =<< generateSecret + +-- | Reads a key from a file. +readKey :: FilePath -> IO Jose.JWK +readKey fp = fromSecret <$> readFile fp diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs new file mode 100644 index 00000000..2e825c0a --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Servant.Auth.Server.Internal where + +import Control.Monad.Trans (liftIO) +import Servant ((:>), Handler, HasServer (..), + Proxy (..), + HasContextEntry(getContextEntry)) +import Servant.Auth +import Servant.Auth.JWT (ToJWT) + +import Servant.Auth.Server.Internal.AddSetCookie +import Servant.Auth.Server.Internal.Class +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.JWT +import Servant.Auth.Server.Internal.Types + +import Servant.Server.Internal (DelayedIO, addAuthCheck, withRequest) + +instance ( n ~ 'S ('S 'Z) + , HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v + , HasServer api ctxs -- this constraint is needed to implement hoistServer + , AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler) + , ToJWT v + , HasContextEntry ctxs CookieSettings + , HasContextEntry ctxs JWTSettings + ) => HasServer (Auth auths v :> api) ctxs where + type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m + +#if MIN_VERSION_servant_server(0,12,0) + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s +#endif + + route _ context subserver = + route (Proxy :: Proxy (AddSetCookiesApi n api)) + context + (fmap go subserver `addAuthCheck` authCheck) + + where + authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))) + authCheck = withRequest $ \req -> liftIO $ do + authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req + cookies <- makeCookies authResult + return (authResult, cookies) + + jwtSettings :: JWTSettings + jwtSettings = getContextEntry context + + cookieSettings :: CookieSettings + cookieSettings = getContextEntry context + + makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z))) + makeCookies authResult = do + xsrf <- makeXsrfCookie cookieSettings + fmap (Just xsrf `SetCookieCons`) $ + case authResult of + (Authenticated v) -> do + ejwt <- makeSessionCookie cookieSettings jwtSettings v + case ejwt of + Nothing -> return $ Nothing `SetCookieCons` SetCookieNil + Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil + _ -> return $ Nothing `SetCookieCons` SetCookieNil + + go :: (AuthResult v -> ServerT api Handler) + -> (AuthResult v, SetCookieList n) + -> ServerT (AddSetCookiesApi n api) Handler + go fn (authResult, cookies) = addSetCookies cookies $ fn authResult diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs new file mode 100644 index 00000000..32857ebe --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/AddSetCookie.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} + +module Servant.Auth.Server.Internal.AddSetCookie where + +import Blaze.ByteString.Builder (toByteString) +import qualified Data.ByteString as BS +import Data.Tagged (Tagged (..)) +import qualified Network.HTTP.Types as HTTP +import Network.Wai (mapResponseHeaders) +import Servant +import Web.Cookie + +-- What are we doing here? Well, the idea is to add headers to the response, +-- but the headers come from the authentication check. In order to do that, we +-- tweak a little the general theme of recursing down the API tree; this time, +-- we recurse down a variation of it that adds headers to all the endpoints. +-- This involves the usual type-level checks. +-- +-- TODO: If the endpoints already have headers, this will not work as is. + +data Nat = Z | S Nat + +type family AddSetCookiesApi (n :: Nat) a where + AddSetCookiesApi ('S 'Z) a = AddSetCookieApi a + AddSetCookiesApi ('S n) a = AddSetCookiesApi n (AddSetCookieApi a) + +type family AddSetCookieApiVerb a where + AddSetCookieApiVerb (Headers ls a) = Headers (Header "Set-Cookie" SetCookie ': ls) a + AddSetCookieApiVerb a = Headers '[Header "Set-Cookie" SetCookie] a + +type family AddSetCookieApi a :: * +type instance AddSetCookieApi (a :> b) = a :> AddSetCookieApi b +type instance AddSetCookieApi (a :<|> b) = AddSetCookieApi a :<|> AddSetCookieApi b +type instance AddSetCookieApi (Verb method stat ctyps a) + = Verb method stat ctyps (AddSetCookieApiVerb a) +type instance AddSetCookieApi Raw = Raw +#if MIN_VERSION_servant_server(0,15,0) +type instance AddSetCookieApi (Stream method stat framing ctyps a) + = Stream method stat framing ctyps (AddSetCookieApiVerb a) +#endif +type instance AddSetCookieApi (Headers hs a) = AddSetCookieApiVerb (Headers hs a) + +data SetCookieList (n :: Nat) :: * where + SetCookieNil :: SetCookieList 'Z + SetCookieCons :: Maybe SetCookie -> SetCookieList n -> SetCookieList ('S n) + +class AddSetCookies (n :: Nat) orig new where + addSetCookies :: SetCookieList n -> orig -> new + +instance {-# OVERLAPS #-} AddSetCookies ('S n) oldb newb + => AddSetCookies ('S n) (a -> oldb) (a -> newb) where + addSetCookies cookies oldfn = addSetCookies cookies . oldfn + +instance AddSetCookies 'Z orig orig where + addSetCookies _ = id + +instance {-# OVERLAPPABLE #-} + ( Functor m + , AddSetCookies n (m old) (m cookied) + , AddHeader "Set-Cookie" SetCookie cookied new + ) => AddSetCookies ('S n) (m old) (m new) where + addSetCookies (mCookie `SetCookieCons` rest) oldVal = + case mCookie of + Nothing -> noHeader <$> addSetCookies rest oldVal + Just cookie -> addHeader cookie <$> addSetCookies rest oldVal + +instance {-# OVERLAPS #-} + (AddSetCookies ('S n) a a', AddSetCookies ('S n) b b') + => AddSetCookies ('S n) (a :<|> b) (a' :<|> b') where + addSetCookies cookies (a :<|> b) = addSetCookies cookies a :<|> addSetCookies cookies b + +-- | for @servant <0.11@ +instance + AddSetCookies ('S n) Application Application where + addSetCookies cookies r request respond + = r request $ respond . mapResponseHeaders (++ mkHeaders cookies) + +-- | for @servant >=0.11@ +instance + AddSetCookies ('S n) (Tagged m Application) (Tagged m Application) where + addSetCookies cookies r = Tagged $ \request respond -> + unTagged r request $ respond . mapResponseHeaders (++ mkHeaders cookies) + +mkHeaders :: SetCookieList x -> [HTTP.Header] +mkHeaders x = ("Set-Cookie",) <$> mkCookies x + where + mkCookies :: forall y. SetCookieList y -> [BS.ByteString] + mkCookies SetCookieNil = [] + mkCookies (SetCookieCons Nothing rest) = mkCookies rest + mkCookies (SetCookieCons (Just y) rest) + = toByteString (renderSetCookie y) : mkCookies rest diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs new file mode 100644 index 00000000..f35eb6f7 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/BasicAuth.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.Server.Internal.BasicAuth where + +#if !MIN_VERSION_servant_server(0,16,0) +#define ServerError ServantErr +#endif + +import qualified Data.ByteString as BS +import Servant (BasicAuthData (..), + ServerError (..), err401) +import Servant.Server.Internal.BasicAuth (decodeBAHdr, + mkBAChallengerHdr) + +import Servant.Auth.Server.Internal.Types + +-- | A 'ServerError' that asks the client to authenticate via Basic +-- Authentication, should be invoked by an application whenever +-- appropriate. The argument is the realm. +wwwAuthenticatedErr :: BS.ByteString -> ServerError +wwwAuthenticatedErr realm = err401 { errHeaders = [mkBAChallengerHdr realm] } + +-- | A type holding the configuration for Basic Authentication. +-- It is defined as a type family with no arguments, so that +-- it can be instantiated to whatever type you need to +-- authenticate your users (use @type instance BasicAuthCfg = ...@). +-- +-- Note that the instantiation is application-wide, +-- i.e. there can be only one instance. +-- As a consequence, it should not be instantiated in a library. +-- +-- Basic Authentication expects an element of type 'BasicAuthCfg' +-- to be in the 'Context'; that element is then passed automatically +-- to the instance of 'FromBasicAuthData' together with the +-- authentication data obtained from the client. +-- +-- If you do not need a configuration for Basic Authentication, +-- you can use just @BasicAuthCfg = ()@, and recall to also +-- add @()@ to the 'Context'. +-- A basic but more interesting example is to take as 'BasicAuthCfg' +-- a list of authorised username/password pairs: +-- +-- > deriving instance Eq BasicAuthData +-- > type instance BasicAuthCfg = [BasicAuthData] +-- > instance FromBasicAuthData User where +-- > fromBasicAuthData authData authCfg = +-- > if elem authData authCfg then ... +type family BasicAuthCfg + +class FromBasicAuthData a where + -- | Whether the username exists and the password is correct. + -- Note that, rather than passing a 'Pass' to the function, we pass a + -- function that checks an 'EncryptedPass'. This is to make sure you don't + -- accidentally do something untoward with the password, like store it. + fromBasicAuthData :: BasicAuthData -> BasicAuthCfg -> IO (AuthResult a) + +basicAuthCheck :: FromBasicAuthData usr => BasicAuthCfg -> AuthCheck usr +basicAuthCheck cfg = AuthCheck $ \req -> case decodeBAHdr req of + Nothing -> return Indefinite + Just baData -> fromBasicAuthData baData cfg diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs new file mode 100644 index 00000000..2f13bbc3 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Class.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.Class where + +import Servant.Auth +import Data.Monoid +import Servant hiding (BasicAuth) + +import Servant.Auth.JWT +import Servant.Auth.Server.Internal.Types +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.BasicAuth +import Servant.Auth.Server.Internal.Cookie +import Servant.Auth.Server.Internal.JWT (jwtAuthCheck) + +-- | @IsAuth a ctx v@ indicates that @a@ is an auth type that expects all +-- elements of @ctx@ to be the in the Context and whose authentication check +-- returns an @AuthCheck v@. +class IsAuth a v where + type family AuthArgs a :: [*] + runAuth :: proxy a -> proxy v -> Unapp (AuthArgs a) (AuthCheck v) + +instance FromJWT usr => IsAuth Cookie usr where + type AuthArgs Cookie = '[CookieSettings, JWTSettings] + runAuth _ _ = cookieAuthCheck + +instance FromJWT usr => IsAuth JWT usr where + type AuthArgs JWT = '[JWTSettings] + runAuth _ _ = jwtAuthCheck + +instance FromBasicAuthData usr => IsAuth BasicAuth usr where + type AuthArgs BasicAuth = '[BasicAuthCfg] + runAuth _ _ = basicAuthCheck + +-- * Helper + +class AreAuths (as :: [*]) (ctxs :: [*]) v where + runAuths :: proxy as -> Context ctxs -> AuthCheck v + +instance AreAuths '[] ctxs v where + runAuths _ _ = mempty + +instance ( AuthCheck v ~ App (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) + , IsAuth a v + , AreAuths as ctxs v + , AppCtx ctxs (AuthArgs a) (Unapp (AuthArgs a) (AuthCheck v)) + ) => AreAuths (a ': as) ctxs v where + runAuths _ ctxs = go <> runAuths (Proxy :: Proxy as) ctxs + where + go = appCtx (Proxy :: Proxy (AuthArgs a)) + ctxs + (runAuth (Proxy :: Proxy a) (Proxy :: Proxy v)) + +type family Unapp ls res where + Unapp '[] res = res + Unapp (arg1 ': rest) res = arg1 -> Unapp rest res + +type family App ls res where + App '[] res = res + App (arg1 ': rest) (arg1 -> res) = App rest res + +-- | @AppCtx@ applies the function @res@ to the arguments in @ls@ by taking the +-- values from the Context provided. +class AppCtx ctx ls res where + appCtx :: proxy ls -> Context ctx -> res -> App ls res + +instance ( HasContextEntry ctxs ctx + , AppCtx ctxs rest res + ) => AppCtx ctxs (ctx ': rest) (ctx -> res) where + appCtx _ ctx fn = appCtx (Proxy :: Proxy rest) ctx $ fn $ getContextEntry ctx + +instance AppCtx ctx '[] res where + appCtx _ _ r = r diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs new file mode 100644 index 00000000..83e5784d --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs @@ -0,0 +1,127 @@ +module Servant.Auth.Server.Internal.ConfigTypes + ( module Servant.Auth.Server.Internal.ConfigTypes + , Servant.API.IsSecure(..) + ) where + +import Crypto.JOSE as Jose +import Crypto.JWT as Jose +import qualified Data.ByteString as BS +import Data.Default.Class +import Data.Time +import GHC.Generics (Generic) +import Servant.API (IsSecure(..)) + +data IsMatch = Matches | DoesNotMatch + deriving (Eq, Show, Read, Generic, Ord) + +data IsPasswordCorrect = PasswordCorrect | PasswordIncorrect + deriving (Eq, Show, Read, Generic, Ord) + +-- The @SameSite@ attribute of cookies determines whether cookies will be sent +-- on cross-origin requests. +-- +-- See +-- for more information. +data SameSite = AnySite | SameSiteStrict | SameSiteLax + deriving (Eq, Show, Read, Generic, Ord) + +-- | @JWTSettings@ are used to generate cookies, and to verify JWTs. +data JWTSettings = JWTSettings + { + -- | Key used to sign JWT. + signingKey :: Jose.JWK + -- | Algorithm used to sign JWT. + , jwtAlg :: Maybe Jose.Alg + -- | Keys used to validate JWT. + , validationKeys :: Jose.JWKSet + -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the + -- intended recipient of the JWT. + , audienceMatches :: Jose.StringOrURI -> IsMatch + } deriving (Generic) + +-- | A @JWTSettings@ where the audience always matches. +defaultJWTSettings :: Jose.JWK -> JWTSettings +defaultJWTSettings k = JWTSettings + { signingKey = k + , jwtAlg = Nothing + , validationKeys = Jose.JWKSet [k] + , audienceMatches = const Matches } + +-- | The policies to use when generating cookies. +-- +-- If *both* 'cookieMaxAge' and 'cookieExpires' are @Nothing@, browsers will +-- treat the cookie as a *session cookie*. These will be deleted when the +-- browser is closed. +-- +-- Note that having the setting @Secure@ may cause testing failures if you are +-- not testing over HTTPS. +data CookieSettings = CookieSettings + { + -- | 'Secure' means browsers will only send cookies over HTTPS. Default: + -- @Secure@. + cookieIsSecure :: !IsSecure + -- | How long from now until the cookie expires. Default: @Nothing@. + , cookieMaxAge :: !(Maybe DiffTime) + -- | At what time the cookie expires. Default: @Nothing@. + , cookieExpires :: !(Maybe UTCTime) + -- | The URL path and sub-paths for which this cookie is used. Default: @Just "/"@. + , cookiePath :: !(Maybe BS.ByteString) + -- | Domain name, if set cookie also allows subdomains. Default: @Nothing@. + , cookieDomain :: !(Maybe BS.ByteString) + -- | 'SameSite' settings. Default: @SameSiteLax@. + , cookieSameSite :: !SameSite + -- | What name to use for the cookie used for the session. + , sessionCookieName :: !BS.ByteString + -- | The optional settings to use for XSRF protection. Default: @Just def@. + , cookieXsrfSetting :: !(Maybe XsrfCookieSettings) + } deriving (Eq, Show, Generic) + +instance Default CookieSettings where + def = defaultCookieSettings + +defaultCookieSettings :: CookieSettings +defaultCookieSettings = CookieSettings + { cookieIsSecure = Secure + , cookieMaxAge = Nothing + , cookieExpires = Nothing + , cookiePath = Just "/" + , cookieDomain = Nothing + , cookieSameSite = SameSiteLax + , sessionCookieName = "JWT-Cookie" + , cookieXsrfSetting = Just def + } + +-- | The policies to use when generating and verifying XSRF cookies +data XsrfCookieSettings = XsrfCookieSettings + { + -- | What name to use for the cookie used for XSRF protection. + xsrfCookieName :: !BS.ByteString + -- | What path to use for the cookie used for XSRF protection. Default @Just "/"@. + , xsrfCookiePath :: !(Maybe BS.ByteString) + -- | What name to use for the header used for XSRF protection. + , xsrfHeaderName :: !BS.ByteString + -- | Exclude GET request method from XSRF protection. + , xsrfExcludeGet :: !Bool + } deriving (Eq, Show, Generic) + +instance Default XsrfCookieSettings where + def = defaultXsrfCookieSettings + +defaultXsrfCookieSettings :: XsrfCookieSettings +defaultXsrfCookieSettings = XsrfCookieSettings + { xsrfCookieName = "XSRF-TOKEN" + , xsrfCookiePath = Just "/" + , xsrfHeaderName = "X-XSRF-TOKEN" + , xsrfExcludeGet = False + } + +------------------------------------------------------------------------------ +-- Internal {{{ + +jwtSettingsToJwtValidationSettings :: JWTSettings -> Jose.JWTValidationSettings +jwtSettingsToJwtValidationSettings s + = defaultJWTValidationSettings (toBool <$> audienceMatches s) + where + toBool Matches = True + toBool DoesNotMatch = False +-- }}} diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs new file mode 100644 index 00000000..a91b42de --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.Server.Internal.Cookie where + +import Blaze.ByteString.Builder (toByteString) +import Control.Monad.Except +import Control.Monad.Reader +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose +import Data.ByteArray (constEq) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as BS64 +import qualified Data.ByteString.Lazy as BSL +import Data.CaseInsensitive (mk) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day(..)) +import Data.Time.Clock (UTCTime(..), secondsToDiffTime) +import Network.HTTP.Types (methodGet) +import Network.HTTP.Types.Header(hCookie) +import Network.Wai (Request, requestHeaders, requestMethod) +import Servant (AddHeader, addHeader) +import System.Entropy (getEntropy) +import Web.Cookie + +import Servant.Auth.JWT (FromJWT (decodeJWT), ToJWT) +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.JWT (makeJWT, verifyJWT) +import Servant.Auth.Server.Internal.Types + + +cookieAuthCheck :: FromJWT usr => CookieSettings -> JWTSettings -> AuthCheck usr +cookieAuthCheck ccfg jwtSettings = do + req <- ask + jwtCookie <- maybe mempty return $ do + cookies' <- lookup hCookie $ requestHeaders req + let cookies = parseCookies cookies' + -- Apply the XSRF check if enabled. + guard $ fromMaybe True $ do + xsrfCookieCfg <- xsrfCheckRequired ccfg req + return $ xsrfCookieAuthCheck xsrfCookieCfg req cookies + -- session cookie *must* be HttpOnly and Secure + lookup (sessionCookieName ccfg) cookies + verifiedJWT <- liftIO $ verifyJWT jwtSettings jwtCookie + case verifiedJWT of + Nothing -> mzero + Just v -> return v + +xsrfCheckRequired :: CookieSettings -> Request -> Maybe XsrfCookieSettings +xsrfCheckRequired cookieSettings req = do + xsrfCookieCfg <- cookieXsrfSetting cookieSettings + let disableForGetReq = xsrfExcludeGet xsrfCookieCfg && requestMethod req == methodGet + guard $ not disableForGetReq + return xsrfCookieCfg + +xsrfCookieAuthCheck :: XsrfCookieSettings -> Request -> [(BS.ByteString, BS.ByteString)] -> Bool +xsrfCookieAuthCheck xsrfCookieCfg req cookies = fromMaybe False $ do + xsrfCookie <- lookup (xsrfCookieName xsrfCookieCfg) cookies + xsrfHeader <- lookup (mk $ xsrfHeaderName xsrfCookieCfg) $ requestHeaders req + return $ xsrfCookie `constEq` xsrfHeader + +-- | Makes a cookie to be used for XSRF. +makeXsrfCookie :: CookieSettings -> IO SetCookie +makeXsrfCookie cookieSettings = case cookieXsrfSetting cookieSettings of + Just xsrfCookieSettings -> makeRealCookie xsrfCookieSettings + Nothing -> return $ noXsrfTokenCookie cookieSettings + where + makeRealCookie xsrfCookieSettings = do + xsrfValue <- BS64.encode <$> getEntropy 32 + return + $ applyXsrfCookieSettings xsrfCookieSettings + $ applyCookieSettings cookieSettings + $ def{ setCookieValue = xsrfValue } + + +-- | Alias for 'makeXsrfCookie'. +makeCsrfCookie :: CookieSettings -> IO SetCookie +makeCsrfCookie = makeXsrfCookie +{-# DEPRECATED makeCsrfCookie "Use makeXsrfCookie instead" #-} + + +-- | Makes a cookie with session information. +makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) +makeSessionCookie cookieSettings jwtSettings v = do + ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings) + case ejwt of + Left _ -> return Nothing + Right jwt -> return + $ Just + $ applySessionCookieSettings cookieSettings + $ applyCookieSettings cookieSettings + $ def{ setCookieValue = BSL.toStrict jwt } + +noXsrfTokenCookie :: CookieSettings -> SetCookie +noXsrfTokenCookie cookieSettings = + applyCookieSettings cookieSettings $ def{ setCookieName = "NO-XSRF-TOKEN", setCookieValue = "" } + +applyCookieSettings :: CookieSettings -> SetCookie -> SetCookie +applyCookieSettings cookieSettings setCookie = setCookie + { setCookieMaxAge = cookieMaxAge cookieSettings + , setCookieExpires = cookieExpires cookieSettings + , setCookiePath = cookiePath cookieSettings + , setCookieDomain = cookieDomain cookieSettings + , setCookieSecure = case cookieIsSecure cookieSettings of + Secure -> True + NotSecure -> False + } + +applyXsrfCookieSettings :: XsrfCookieSettings -> SetCookie -> SetCookie +applyXsrfCookieSettings xsrfCookieSettings setCookie = setCookie + { setCookieName = xsrfCookieName xsrfCookieSettings + , setCookiePath = xsrfCookiePath xsrfCookieSettings + , setCookieHttpOnly = False + } + +applySessionCookieSettings :: CookieSettings -> SetCookie -> SetCookie +applySessionCookieSettings cookieSettings setCookie = setCookie + { setCookieName = sessionCookieName cookieSettings + , setCookieSameSite = case cookieSameSite cookieSettings of + AnySite -> anySite + SameSiteStrict -> Just sameSiteStrict + SameSiteLax -> Just sameSiteLax + , setCookieHttpOnly = True + } + where +#if MIN_VERSION_cookie(0,4,5) + anySite = Just sameSiteNone +#else + anySite = Nothing +#endif + +-- | For a JWT-serializable session, returns a function that decorates a +-- provided response object with XSRF and session cookies. This should be used +-- when a user successfully authenticates with credentials. +acceptLogin :: ( ToJWT session + , AddHeader "Set-Cookie" SetCookie response withOneCookie + , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) + => CookieSettings + -> JWTSettings + -> session + -> IO (Maybe (response -> withTwoCookies)) +acceptLogin cookieSettings jwtSettings session = do + mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session + case mSessionCookie of + Nothing -> pure Nothing + Just sessionCookie -> do + xsrfCookie <- makeXsrfCookie cookieSettings + return $ Just $ addHeader sessionCookie . addHeader xsrfCookie + +-- | Arbitrary cookie expiry time set back in history after unix time 0 +expireTime :: UTCTime +expireTime = UTCTime (ModifiedJulianDay 50000) 0 + +-- | Adds headers to a response that clears all session cookies +-- | using max-age and expires cookie attributes. +clearSession :: ( AddHeader "Set-Cookie" SetCookie response withOneCookie + , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies ) + => CookieSettings + -> response + -> withTwoCookies +clearSession cookieSettings = addHeader clearedSessionCookie . addHeader clearedXsrfCookie + where + -- According to RFC6265 max-age takes precedence, but IE/Edge ignore it completely so we set both + cookieSettingsExpires = cookieSettings + { cookieExpires = Just expireTime + , cookieMaxAge = Just (secondsToDiffTime 0) + } + clearedSessionCookie = applySessionCookieSettings cookieSettingsExpires $ applyCookieSettings cookieSettingsExpires def + clearedXsrfCookie = case cookieXsrfSetting cookieSettings of + Just xsrfCookieSettings -> applyXsrfCookieSettings xsrfCookieSettings $ applyCookieSettings cookieSettingsExpires def + Nothing -> noXsrfTokenCookie cookieSettingsExpires + +makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) +makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c + +-- | Alias for 'makeSessionCookie'. +makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie) +makeCookie = makeSessionCookie +{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-} + +-- | Alias for 'makeSessionCookieBS'. +makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString) +makeCookieBS = makeSessionCookieBS +{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-} diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs new file mode 100644 index 00000000..5301640c --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/FormLogin.hs @@ -0,0 +1,3 @@ +module Servant.Auth.Server.Internal.FormLogin where + + diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs new file mode 100644 index 00000000..57c0630c --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs @@ -0,0 +1,71 @@ +module Servant.Auth.Server.Internal.JWT where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.Reader +import qualified Crypto.JOSE as Jose +import qualified Crypto.JWT as Jose +import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, + toJSON) +import Data.ByteArray (constEq) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Time (UTCTime) +import Network.Wai (requestHeaders) + +import Servant.Auth.JWT (FromJWT(..), ToJWT(..)) +import Servant.Auth.Server.Internal.ConfigTypes +import Servant.Auth.Server.Internal.Types + + +-- | A JWT @AuthCheck@. You likely won't need to use this directly unless you +-- are protecting a @Raw@ endpoint. +jwtAuthCheck :: FromJWT usr => JWTSettings -> AuthCheck usr +jwtAuthCheck jwtSettings = do + req <- ask + token <- maybe mempty return $ do + authHdr <- lookup "Authorization" $ requestHeaders req + let bearer = "Bearer " + (mbearer, rest) = BS.splitAt (BS.length bearer) authHdr + guard (mbearer `constEq` bearer) + return rest + verifiedJWT <- liftIO $ verifyJWT jwtSettings token + case verifiedJWT of + Nothing -> mzero + Just v -> return v + +-- | Creates a JWT containing the specified data. The data is stored in the +-- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the +-- token expires. +makeJWT :: ToJWT a + => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString) +makeJWT v cfg expiry = runExceptT $ do + bestAlg <- Jose.bestJWSAlg $ signingKey cfg + let alg = fromMaybe bestAlg $ jwtAlg cfg + ejwt <- Jose.signClaims (signingKey cfg) + (Jose.newJWSHeader ((), alg)) + (addExp $ encodeJWT v) + + return $ Jose.encodeCompact ejwt + where + addExp claims = case expiry of + Nothing -> claims + Just e -> claims & Jose.claimExp ?~ Jose.NumericDate e + + +verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a) +verifyJWT jwtCfg input = do + verifiedJWT <- liftIO $ runExceptT $ do + unverifiedJWT <- Jose.decodeCompact (BSL.fromStrict input) + Jose.verifyClaims + (jwtSettingsToJwtValidationSettings jwtCfg) + (validationKeys jwtCfg) + unverifiedJWT + return $ case verifiedJWT of + Left (_ :: Jose.JWTError) -> Nothing + Right v -> case decodeJWT v of + Left _ -> Nothing + Right v' -> Just v' \ No newline at end of file diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs new file mode 100644 index 00000000..956af6b8 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ThrowAll.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE UndecidableInstances #-} +module Servant.Auth.Server.Internal.ThrowAll where + +#if !MIN_VERSION_servant_server(0,16,0) +#define ServerError ServantErr +#endif + +import Control.Monad.Error.Class +import Data.Tagged (Tagged (..)) +import Servant ((:<|>) (..), ServerError(..)) +import Network.HTTP.Types +import Network.Wai + +import qualified Data.ByteString.Char8 as BS + +class ThrowAll a where + -- | 'throwAll' is a convenience function to throw errors across an entire + -- sub-API + -- + -- + -- > throwAll err400 :: Handler a :<|> Handler b :<|> Handler c + -- > == throwError err400 :<|> throwError err400 :<|> err400 + throwAll :: ServerError -> a + +instance (ThrowAll a, ThrowAll b) => ThrowAll (a :<|> b) where + throwAll e = throwAll e :<|> throwAll e + +-- Really this shouldn't be necessary - ((->) a) should be an instance of +-- MonadError, no? +instance {-# OVERLAPPING #-} ThrowAll b => ThrowAll (a -> b) where + throwAll e = const $ throwAll e + +instance {-# OVERLAPPABLE #-} (MonadError ServerError m) => ThrowAll (m a) where + throwAll = throwError + +-- | for @servant <0.11@ +instance {-# OVERLAPPING #-} ThrowAll Application where + throwAll e _req respond + = respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) + (errHeaders e) + (errBody e) + +-- | for @servant >=0.11@ +instance {-# OVERLAPPING #-} MonadError ServerError m => ThrowAll (Tagged m Application) where + throwAll e = Tagged $ \_req respond -> + respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e)) + (errHeaders e) + (errBody e) diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs new file mode 100644 index 00000000..8e9e91f1 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Types.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.Server.Internal.Types where + +import Control.Applicative +import Control.Monad.Reader +import Control.Monad.Time +import Data.Monoid (Monoid (..)) +import Data.Semigroup (Semigroup (..)) +import Data.Time (getCurrentTime) +import GHC.Generics (Generic) +import Network.Wai (Request) + +import qualified Control.Monad.Fail as Fail + +-- | The result of an authentication attempt. +data AuthResult val + = BadPassword + | NoSuchUser + -- | Authentication succeeded. + | Authenticated val + -- | If an authentication procedure cannot be carried out - if for example it + -- expects a password and username in a header that is not present - + -- @Indefinite@ is returned. This indicates that other authentication + -- methods should be tried. + | Indefinite + deriving (Eq, Show, Read, Generic, Ord, Functor, Traversable, Foldable) + +instance Semigroup (AuthResult val) where + Indefinite <> y = y + x <> _ = x + +instance Monoid (AuthResult val) where + mempty = Indefinite + mappend = (<>) + +instance Applicative AuthResult where + pure = return + (<*>) = ap + +instance Monad AuthResult where + return = Authenticated + Authenticated v >>= f = f v + BadPassword >>= _ = BadPassword + NoSuchUser >>= _ = NoSuchUser + Indefinite >>= _ = Indefinite + +instance Alternative AuthResult where + empty = mzero + (<|>) = mplus + +instance MonadPlus AuthResult where + mzero = mempty + mplus = (<>) + + +-- | An @AuthCheck@ is the function used to decide the authentication status +-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a +-- Monoid or Alternative; the semantics of this is that the *first* +-- non-'Indefinite' result from left to right is used and the rest are ignored. +newtype AuthCheck val = AuthCheck + { runAuthCheck :: Request -> IO (AuthResult val) } + deriving (Generic, Functor) + +instance Semigroup (AuthCheck val) where + AuthCheck f <> AuthCheck g = AuthCheck $ \x -> do + fx <- f x + case fx of + Indefinite -> g x + r -> pure r + +instance Monoid (AuthCheck val) where + mempty = AuthCheck $ const $ return mempty + mappend = (<>) + +instance Applicative AuthCheck where + pure = return + (<*>) = ap + +instance Monad AuthCheck where + return = AuthCheck . return . return . return + AuthCheck ac >>= f = AuthCheck $ \req -> do + aresult <- ac req + case aresult of + Authenticated usr -> runAuthCheck (f usr) req + BadPassword -> return BadPassword + NoSuchUser -> return NoSuchUser + Indefinite -> return Indefinite + +#if !MIN_VERSION_base(4,13,0) + fail = Fail.fail +#endif + +instance Fail.MonadFail AuthCheck where + fail _ = AuthCheck . const $ return Indefinite + +instance MonadReader Request AuthCheck where + ask = AuthCheck $ \x -> return (Authenticated x) + local f (AuthCheck check) = AuthCheck $ \req -> check (f req) + +instance MonadIO AuthCheck where + liftIO action = AuthCheck $ const $ Authenticated <$> action + +instance MonadTime AuthCheck where + currentTime = liftIO getCurrentTime + +instance Alternative AuthCheck where + empty = mzero + (<|>) = mplus + +instance MonadPlus AuthCheck where + mzero = mempty + mplus = (<>) diff --git a/servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs b/servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs new file mode 100644 index 00000000..de87ad27 --- /dev/null +++ b/servant-auth/servant-auth-server/src/Servant/Auth/Server/SetCookieOrphan.hs @@ -0,0 +1,3 @@ +module Servant.Auth.Server.SetCookieOrphan + {-# DEPRECATED "instance exists in http-api-data-0.3.9. This module will be removed in next major release." #-} + () where diff --git a/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs new file mode 100644 index 00000000..75257f34 --- /dev/null +++ b/servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs @@ -0,0 +1,600 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.ServerSpec (spec) where + +#if !MIN_VERSION_servant_server(0,16,0) +#define ServerError ServantErr +#endif + +import Control.Lens +import Control.Monad.Except (runExceptT) +import Control.Monad.IO.Class (liftIO) +import Crypto.JOSE (Alg (HS256, None), Error, + JWK, JWSHeader, + KeyMaterialGenParam (OctGenParam), + ToCompact, encodeCompact, + genJWK, newJWSHeader) +import Crypto.JWT (Audience (..), ClaimsSet, + NumericDate (NumericDate), + SignedJWT, + claimAud, claimNbf, + signClaims, + emptyClaimsSet, + unregisteredClaims) +import Data.Aeson (FromJSON, ToJSON, Value, + toJSON, encode) +import Data.Aeson.Lens (_JSON) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.CaseInsensitive (mk) +import Data.Foldable (find) +import Data.Monoid +import Data.Time +import Data.Time.Clock (getCurrentTime) +import GHC.Generics (Generic) +import Network.HTTP.Client (cookie_http_only, + cookie_name, cookie_value, + cookie_expiry_time, + destroyCookieJar) +import Network.HTTP.Types (Status, status200, + status401) +import Network.Wai (responseLBS) +import Network.Wai.Handler.Warp (testWithApplication) +import Network.Wreq (Options, auth, basicAuth, + cookieExpiryTime, cookies, + defaults, get, getWith, postWith, + header, oauth2Bearer, + responseBody, + responseCookieJar, + responseHeader, + responseStatus) +import Network.Wreq.Types (Postable(..)) +import Servant hiding (BasicAuth, + IsSecure (..), header) +import Servant.Auth.Server +import Servant.Auth.Server.Internal.Cookie (expireTime) +import Servant.Auth.Server.SetCookieOrphan () +#if MIN_VERSION_servant_server(0,15,0) +import qualified Servant.Types.SourceT as S +#endif +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec +import Test.QuickCheck +import qualified Network.HTTP.Client as HCli + + + +spec :: Spec +spec = do + authSpec + cookieAuthSpec + jwtAuthSpec + throwAllSpec + basicAuthSpec + +------------------------------------------------------------------------------ +-- * Auth {{{ + +authSpec :: Spec +authSpec + = describe "The Auth combinator" + $ around (testWithApplication . return $ app jwtAndCookieApi) $ do + + it "returns a 401 if all authentications are Indefinite" $ \port -> do + get (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if one authentication suceeds" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "fails (403) if one authentication fails" $ const $ + pendingWith "Authentications don't yet fail, only are Indefinite" + + it "doesn't clobber pre-existing response headers" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/header") + resp ^. responseHeader "Blah" `shouldBe` "1797" + resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") + + context "Raw" $ do + + it "gets the response body" $ \port -> property $ \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/raw") + resp ^. responseBody `shouldBe` "how are you?" + + it "doesn't clobber pre-existing reponse headers" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg Nothing + opts <- addJwtToHeader jwt + resp <- getWith opts (url port ++ "/raw") + resp ^. responseHeader "hi" `shouldBe` "there" + resp ^. responseHeader "Set-Cookie" `shouldSatisfy` (/= "") + + + context "Setting cookies" $ do + + it "sets cookies that it itself accepts" $ \port -> property $ \user -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) + $ destroyCookieJar cookieJar + opts2 = defaults + & cookies .~ Just cookieJar + & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [cookie_value xxsrf] + resp2 <- getWith opts2 (url port) + resp2 ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "uses the Expiry from the configuration" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg) + $ destroyCookieJar cookieJar + xxsrf ^. cookieExpiryTime `shouldBe` future + + it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + let (cookieJar:_) = resp ^.. responseCookieJar + Just token = find (\x -> cookie_name x == sessionCookieName cookieCfg) + $ destroyCookieJar cookieJar + cookie_http_only token `shouldBe` True + + + +-- }}} +------------------------------------------------------------------------------ +-- * Cookie Auth {{{ + +cookieAuthSpec :: Spec +cookieAuthSpec + = describe "The Auth combinator" $ do + describe "With XSRF check" $ + around (testWithApplication . return $ app cookieOnlyApi) $ do + + it "fails if XSRF header and cookie don't match" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blerg") + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "fails with no XSRF header or cookie" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfg jwt + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if XSRF header and cookie match, and JWT is valid" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts' <- addJwtToCookie cookieCfg jwt + let opts = addCookie (opts' & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ ["blah"]) + (xsrfField xsrfCookieName cookieCfg <> "=blah") + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "sets and clears the right cookies" $ \port -> property + $ \(user :: User) -> do + let optsFromResp resp = + let jar = resp ^. responseCookieJar + Just xsrfCookieValue = cookie_value <$> find (\c -> cookie_name c == xsrfField xsrfCookieName cookieCfg) (destroyCookieJar jar) + in defaults + & cookies .~ Just jar -- real cookie jars aren't updated by being replaced + & header (mk (xsrfField xsrfHeaderName cookieCfg)) .~ [xsrfCookieValue] + + resp <- postWith defaults (url port ++ "/login") user + (resp ^. responseCookieJar) `shouldMatchCookieNames` + [ sessionCookieName cookieCfg + , xsrfField xsrfCookieName cookieCfg + ] + let loggedInOpts = optsFromResp resp + + resp <- getWith loggedInOpts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + -- logout + resp <- getWith loggedInOpts (url port ++ "/logout") + + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + + let loggedOutOpts = optsFromResp resp + getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 + + describe "With no XSRF check for GET requests" $ let + noXsrfGet xsrfCfg = xsrfCfg { xsrfExcludeGet = True } + cookieCfgNoXsrfGet = cookieCfg { cookieXsrfSetting = fmap noXsrfGet $ cookieXsrfSetting cookieCfg } + in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrfGet) $ do + + it "succeeds with no XSRF header or cookie for GET" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrfGet jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "fails with no XSRF header or cookie for POST" $ \port -> property + $ \(user :: User) number -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrfGet jwt + postWith opts (url port) (toJSON (number :: Int)) `shouldHTTPErrorWith` status401 + + describe "With no XSRF check at all" $ let + cookieCfgNoXsrf = cookieCfg { cookieXsrfSetting = Nothing } + in around (testWithApplication . return $ appWithCookie cookieOnlyApi cookieCfgNoXsrf) $ do + + it "succeeds with no XSRF header or cookie for GET" $ \port -> property + $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrf jwt + resp <- getWith opts (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + it "succeeds with no XSRF header or cookie for POST" $ \port -> property + $ \(user :: User) number -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims $ toJSON user) + opts <- addJwtToCookie cookieCfgNoXsrf jwt + resp <- postWith opts (url port) $ toJSON (number :: Int) + resp ^? responseBody . _JSON `shouldBe` Just number + + it "sets and clears the right cookies" $ \port -> property + $ \(user :: User) -> do + let optsFromResp resp = defaults + & cookies .~ Just (resp ^. responseCookieJar) -- real cookie jars aren't updated by being replaced + + resp <- postWith defaults (url port ++ "/login") user + (resp ^. responseCookieJar) `shouldMatchCookieNames` + [ sessionCookieName cookieCfg + , "NO-XSRF-TOKEN" + ] + let loggedInOpts = optsFromResp resp + + resp <- getWith (loggedInOpts) (url port) + resp ^? responseBody . _JSON `shouldBe` Just (length $ name user) + + resp <- getWith loggedInOpts (url port ++ "/logout") + (resp ^. responseCookieJar) `shouldMatchCookieNameValues` + [ (sessionCookieName cookieCfg, "value") + , ("NO-XSRF-TOKEN", "") + ] + + -- assert cookies were expired + now <- getCurrentTime + let assertCookie c = now >= cookie_expiry_time c + all assertCookie (destroyCookieJar (resp ^. responseCookieJar)) `shouldBe` True + + let loggedOutOpts = optsFromResp resp + + getWith loggedOutOpts (url port) `shouldHTTPErrorWith` status401 + +-- }}} +------------------------------------------------------------------------------ +-- * JWT Auth {{{ + +jwtAuthSpec :: Spec +jwtAuthSpec + = describe "The JWT combinator" + $ around (testWithApplication . return $ app jwtOnlyApi) $ do + + it "fails if 'aud' does not match predicate" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["boo"])) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if 'aud' does match predicate" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimAud .~ Just (Audience ["anythingElse"])) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status200 + + it "fails if 'nbf' is set to a future date" $ \port -> property $ + \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims (toJSON user) & claimNbf .~ Just (NumericDate future)) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "fails if 'exp' is set to a past date" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg (Just past) + opts <- addJwtToHeader jwt + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "succeeds if 'exp' is set to a future date" $ \port -> property $ + \(user :: User) -> do + jwt <- makeJWT user jwtCfg (Just future) + opts <- addJwtToHeader jwt + resp <- getWith opts (url port) + resp ^. responseStatus `shouldBe` status200 + + it "fails if JWT is not signed" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), None)) + (claims $ toJSON user) + opts <- addJwtToHeader (jwt >>= (return . encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "fails if JWT does not use expected algorithm" $ const $ + pendingWith "Need https://github.com/frasertweedale/hs-jose/issues/19" + + it "fails if data is not valid JSON" $ \port -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) (claims "{{") + opts <- addJwtToHeader (jwt >>= (return .encodeCompact)) + getWith opts (url port) `shouldHTTPErrorWith` status401 + + it "suceeds as wreq's oauth2Bearer" $ \port -> property $ \(user :: User) -> do + jwt <- createJWT theKey (newJWSHeader ((), HS256)) + (claims $ toJSON user) + resp <- case jwt >>= (return . encodeCompact) of + Left (e :: Error) -> fail $ show e + Right v -> getWith (defaults & auth ?~ oauth2Bearer (BSL.toStrict v)) (url port) + resp ^. responseStatus `shouldBe` status200 + +-- }}} +------------------------------------------------------------------------------ +-- * Basic Auth {{{ + +basicAuthSpec :: Spec +basicAuthSpec = describe "The BasicAuth combinator" + $ around (testWithApplication . return $ app basicAuthApi) $ do + + it "succeeds with the correct password and username" $ \port -> do + resp <- getWith (defaults & auth ?~ basicAuth "ali" "Open sesame") (url port) + resp ^. responseStatus `shouldBe` status200 + + it "fails with non-existent user" $ \port -> do + getWith (defaults & auth ?~ basicAuth "thief" "Open sesame") (url port) + `shouldHTTPErrorWith` status401 + + it "fails with incorrect password" $ \port -> do + getWith (defaults & auth ?~ basicAuth "ali" "phatic") (url port) + `shouldHTTPErrorWith` status401 + + it "fails with no auth header" $ \port -> do + get (url port) `shouldHTTPErrorWith` status401 + +-- }}} +------------------------------------------------------------------------------ +-- * ThrowAll {{{ + +throwAllSpec :: Spec +throwAllSpec = describe "throwAll" $ do + + it "works for plain values" $ do + let t :: Either ServerError Int :<|> Either ServerError Bool :<|> Either ServerError String + t = throwAll err401 + t `shouldBe` throwError err401 :<|> throwError err401 :<|> throwError err401 + + it "works for function types" $ property $ \i -> do + let t :: Int -> (Either ServerError Bool :<|> Either ServerError String) + t = throwAll err401 + expected _ = throwError err401 :<|> throwError err401 + t i `shouldBe` expected i + +-- }}} +------------------------------------------------------------------------------ +-- * API and Server {{{ + +type API auths + = Auth auths User :> + ( Get '[JSON] Int + :<|> ReqBody '[JSON] Int :> Post '[JSON] Int + :<|> "header" :> Get '[JSON] (Headers '[Header "Blah" Int] Int) +#if MIN_VERSION_servant_server(0,15,0) + :<|> "stream" :> StreamGet NoFraming OctetStream (SourceIO BS.ByteString) +#endif + :<|> "raw" :> Raw + ) + :<|> "login" :> ReqBody '[JSON] User :> Post '[JSON] (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + :<|> "logout" :> Get '[JSON] (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + +jwtOnlyApi :: Proxy (API '[Servant.Auth.Server.JWT]) +jwtOnlyApi = Proxy + +cookieOnlyApi :: Proxy (API '[Cookie]) +cookieOnlyApi = Proxy + +basicAuthApi :: Proxy (API '[BasicAuth]) +basicAuthApi = Proxy + +jwtAndCookieApi :: Proxy (API '[Servant.Auth.Server.JWT, Cookie]) +jwtAndCookieApi = Proxy + +theKey :: JWK +theKey = unsafePerformIO . genJWK $ OctGenParam 256 +{-# NOINLINE theKey #-} + + +cookieCfg :: CookieSettings +cookieCfg = def + { cookieExpires = Just future + , cookieIsSecure = NotSecure + , sessionCookieName = "RuncibleSpoon" + , cookieXsrfSetting = pure $ def + { xsrfCookieName = "TheyDinedOnMince" + , xsrfHeaderName = "AndSlicesOfQuince" + } + } +xsrfField :: (XsrfCookieSettings -> a) -> CookieSettings -> a +xsrfField f = maybe (error "expected XsrfCookieSettings for test") f . cookieXsrfSetting + +jwtCfg :: JWTSettings +jwtCfg = (defaultJWTSettings theKey) { audienceMatches = \x -> + if x == "boo" then DoesNotMatch else Matches } + +instance FromBasicAuthData User where + fromBasicAuthData (BasicAuthData usr pwd) _ + = return $ if usr == "ali" && pwd == "Open sesame" + then Authenticated $ User "ali" "ali@the-thieves-den.com" + else Indefinite + +-- Could be anything, really, but since this is already in the cfg we don't +-- have to add it +type instance BasicAuthCfg = JWK + +appWithCookie :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User + => Proxy (API auths) -> CookieSettings -> Application +appWithCookie api ccfg = serveWithContext api ctx $ server ccfg + where + ctx = ccfg :. jwtCfg :. theKey :. EmptyContext + +-- | Takes a proxy parameter indicating which authentication systems to enable. +app :: AreAuths auths '[CookieSettings, JWTSettings, JWK] User + => Proxy (API auths) -> Application +app api = appWithCookie api cookieCfg + +server :: CookieSettings -> Server (API auths) +server ccfg = + (\authResult -> case authResult of + Authenticated usr -> getInt usr + :<|> postInt usr + :<|> getHeaderInt +#if MIN_VERSION_servant_server(0,15,0) + :<|> return (S.source ["bytestring"]) +#endif + :<|> raw + Indefinite -> throwAll err401 + _ -> throwAll err403 + ) + :<|> getLogin + :<|> getLogout + where + getInt :: User -> Handler Int + getInt usr = return . length $ name usr + + postInt :: User -> Int -> Handler Int + postInt _ = return + + getHeaderInt :: Handler (Headers '[Header "Blah" Int] Int) + getHeaderInt = return $ addHeader 1797 17 + + getLogin :: User -> Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + getLogin user = do + maybeApplyCookies <- liftIO $ acceptLogin ccfg jwtCfg user + case maybeApplyCookies of + Just applyCookies -> return $ applyCookies NoContent + Nothing -> error "cookies failed to apply" + + getLogout :: Handler (Headers '[ Header "Set-Cookie" SetCookie + , Header "Set-Cookie" SetCookie ] NoContent) + getLogout = return $ clearSession ccfg NoContent + + raw :: Server Raw + raw = +#if MIN_VERSION_servant_server(0,11,0) + Tagged $ +#endif + \_req respond -> + respond $ responseLBS status200 [("hi", "there")] "how are you?" + +-- }}} +------------------------------------------------------------------------------ +-- * Utils {{{ + +past :: UTCTime +past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01" + +future :: UTCTime +future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01" + +addJwtToHeader :: Either Error BSL.ByteString -> IO Options +addJwtToHeader jwt = case jwt of + Left e -> fail $ show e + Right v -> return + $ defaults & header "Authorization" .~ ["Bearer " <> BSL.toStrict v] + +createJWT :: JWK -> JWSHeader () -> ClaimsSet -> IO (Either Error Crypto.JWT.SignedJWT) +createJWT k a b = runExceptT $ signClaims k a b + +addJwtToCookie :: ToCompact a => CookieSettings -> Either Error a -> IO Options +addJwtToCookie ccfg jwt = case jwt >>= (return . encodeCompact) of + Left e -> fail $ show e + Right v -> return + $ defaults & header "Cookie" .~ [sessionCookieName ccfg <> "=" <> BSL.toStrict v] + +addCookie :: Options -> BS.ByteString -> Options +addCookie opts cookie' = opts & header "Cookie" %~ \c -> case c of + [h] -> [cookie' <> "; " <> h] + [] -> [cookie'] + _ -> error "expecting single cookie header" + + +shouldHTTPErrorWith :: IO a -> Status -> Expectation +shouldHTTPErrorWith act stat = act `shouldThrow` \e -> case e of +#if MIN_VERSION_http_client(0,5,0) + HCli.HttpExceptionRequest _ (HCli.StatusCodeException resp _) + -> HCli.responseStatus resp == stat +#else + HCli.StatusCodeException x _ _ -> x == stat +#endif + _ -> False + +shouldMatchCookieNames :: HCli.CookieJar -> [BS.ByteString] -> Expectation +shouldMatchCookieNames cj patterns + = fmap cookie_name (destroyCookieJar cj) + `shouldMatchList` patterns + +shouldMatchCookieNameValues :: HCli.CookieJar -> [(BS.ByteString, BS.ByteString)] -> Expectation +shouldMatchCookieNameValues cj patterns + = fmap ((,) <$> cookie_name <*> cookie_value) (destroyCookieJar cj) + `shouldMatchList` patterns + +url :: Int -> String +url port = "http://localhost:" <> show port + +claims :: Value -> ClaimsSet +claims val = emptyClaimsSet & unregisteredClaims . at "dat" .~ Just val +-- }}} +------------------------------------------------------------------------------ +-- * Types {{{ + +data User = User + { name :: String + , _id :: String + } deriving (Eq, Show, Read, Generic) + +instance FromJWT User +instance ToJWT User +instance FromJSON User +instance ToJSON User + +instance Arbitrary User where + arbitrary = User <$> arbitrary <*> arbitrary + +instance Postable User where + postPayload user request = return $ request + { HCli.requestBody = HCli.RequestBodyLBS $ encode user + , HCli.requestHeaders = (mk "Content-Type", "application/json") : HCli.requestHeaders request + } + + +-- }}} diff --git a/servant-auth/servant-auth-server/test/Spec.hs b/servant-auth/servant-auth-server/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-server/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth-swagger/.ghci b/servant-auth/servant-auth-swagger/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth-swagger/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth-swagger/CHANGELOG.md b/servant-auth/servant-auth-swagger/CHANGELOG.md new file mode 100644 index 00000000..7c14608a --- /dev/null +++ b/servant-auth/servant-auth-swagger/CHANGELOG.md @@ -0,0 +1,24 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) +and this project adheres to [PVP Versioning](https://pvp.haskell.org/). + +## [Unreleased] + +## [0.2.10.1] - 2020-10-06 + +### Changed + +- Support GHC 8.10 @domenkozar +- Fix build with swagger 2.5.x @domenkozar + +## [0.2.10.0] - 2018-06-18 + +### Added + +- Support for GHC 8.4 by @phadej +- Changelog by @domenkozar +- #93: Add Cookie in SwaggerSpec API by @domenkozar +- #42: Add dummy AllHasSecurity Cookie instance by @sordina diff --git a/servant-auth/servant-auth-swagger/LICENSE b/servant-auth/servant-auth-swagger/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth-swagger/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/servant-auth/servant-auth-swagger/Setup.hs b/servant-auth/servant-auth-swagger/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth-swagger/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal b/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal new file mode 100644 index 00000000..840a7591 --- /dev/null +++ b/servant-auth/servant-auth-swagger/servant-auth-swagger.cabal @@ -0,0 +1,74 @@ +name: servant-auth-swagger +version: 0.2.10.1 +synopsis: servant-swagger/servant-auth compatibility +description: This package provides instances that allow generating swagger2 schemas from + + APIs that use + @Auth@ combinator. + . + For a quick overview of the usage, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/haskell-servant/servant + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.10 && < 4.16 + , text >= 1.2.3.0 && < 1.3 + , servant-swagger >= 1.1.5 && < 1.8 + , swagger2 >= 2.2.2 && < 2.7 + , servant >= 0.13 && < 0.19 + , servant-auth == 0.4.* + , lens >= 4.16.1 && < 5.1 + if impl(ghc >= 9) + buildable: False + exposed-modules: + Servant.Auth.Swagger + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.9 + -- dependencies with bounds inherited from the library stanza + build-depends: + base + , text + , servant-swagger + , swagger2 + , servant + , servant-auth + , lens + if impl(ghc >= 9) + buildable: False + + -- test dependencies + build-depends: + servant-auth-swagger + , hspec >= 2.5.5 && < 2.9 + , QuickCheck >= 2.11.3 && < 2.15 + other-modules: + Servant.Auth.SwaggerSpec + default-language: Haskell2010 diff --git a/servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs b/servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs new file mode 100644 index 00000000..ec6314ca --- /dev/null +++ b/servant-auth/servant-auth-swagger/src/Servant/Auth/Swagger.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE CPP #-} +module Servant.Auth.Swagger + ( + -- | The purpose of this package is provide the instance for 'servant-auth' + -- combinators needed for 'servant-swagger' documentation generation. + -- + -- Currently only JWT and BasicAuth are supported. + + -- * Re-export + JWT + , BasicAuth + , Auth + + -- * Needed to define instances of @HasSwagger@ + , HasSecurity (..) + ) where + +import Control.Lens ((&), (<>~)) +import Data.Proxy (Proxy (Proxy)) +import Data.Swagger (ApiKeyLocation (..), ApiKeyParams (..), + SecurityRequirement (..), SecurityScheme (..), +#if MIN_VERSION_swagger2(2,6,0) + SecurityDefinitions(..), +#endif + SecuritySchemeType (..), allOperations, security, + securityDefinitions) +import GHC.Exts (fromList) +import Servant.API hiding (BasicAuth) +import Servant.Auth +import Servant.Swagger + +import qualified Data.Text as T + +instance (AllHasSecurity xs, HasSwagger api) => HasSwagger (Auth xs r :> api) where + toSwagger _ + = toSwagger (Proxy :: Proxy api) + & securityDefinitions <>~ mkSec (fromList secs) + & allOperations.security <>~ secReqs + where + secs = securities (Proxy :: Proxy xs) + secReqs = [ SecurityRequirement (fromList [(s,[])]) | (s,_) <- secs] + mkSec = +#if MIN_VERSION_swagger2(2,6,0) + SecurityDefinitions +#else + id +#endif + + +class HasSecurity x where + securityName :: Proxy x -> T.Text + securityScheme :: Proxy x -> SecurityScheme + +instance HasSecurity BasicAuth where + securityName _ = "BasicAuth" + securityScheme _ = SecurityScheme type_ (Just desc) + where + type_ = SecuritySchemeBasic + desc = "Basic access authentication" + +instance HasSecurity JWT where + securityName _ = "JwtSecurity" + securityScheme _ = SecurityScheme type_ (Just desc) + where + type_ = SecuritySchemeApiKey (ApiKeyParams "Authorization" ApiKeyHeader) + desc = "JSON Web Token-based API key" + +class AllHasSecurity (x :: [*]) where + securities :: Proxy x -> [(T.Text,SecurityScheme)] + +instance {-# OVERLAPPABLE #-} (HasSecurity x, AllHasSecurity xs) => AllHasSecurity (x ': xs) where + securities _ = (securityName px, securityScheme px) : securities pxs + where + px :: Proxy x + px = Proxy + pxs :: Proxy xs + pxs = Proxy + +instance {-# OVERLAPPING #-} AllHasSecurity xs => AllHasSecurity (Cookie ': xs) where + securities _ = securities pxs + where + pxs :: Proxy xs + pxs = Proxy + +instance AllHasSecurity '[] where + securities _ = [] diff --git a/servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs b/servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs new file mode 100644 index 00000000..1bfda413 --- /dev/null +++ b/servant-auth/servant-auth-swagger/test/Servant/Auth/SwaggerSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +module Servant.Auth.SwaggerSpec (spec) where + +import Control.Lens +import Data.Proxy +import Servant.API +import Servant.Auth +import Servant.Auth.Swagger +import Data.Swagger +import Servant.Swagger +import Test.Hspec + +spec :: Spec +spec = describe "HasSwagger instance" $ do + + let swag = toSwagger (Proxy :: Proxy API) + + it "adds security definitions at the top level" $ do +#if MIN_VERSION_swagger2(2,6,0) + let (SecurityDefinitions secDefs) = swag ^. securityDefinitions +#else + let secDefs = swag ^. securityDefinitions +#endif + length secDefs `shouldSatisfy` (> 0) + + it "adds security at sub-apis" $ do + swag ^. security `shouldBe` [] + show (swag ^. paths . at "/secure") `shouldContain` "JwtSecurity" + show (swag ^. paths . at "/insecure") `shouldNotContain` "JwtSecurity" + +-- * API + +type API = "secure" :> Auth '[JWT, Cookie] Int :> SecureAPI + :<|> "insecure" :> InsecureAPI + +type SecureAPI = Get '[JSON] Int :<|> ReqBody '[JSON] Int :> Post '[JSON] Int + +type InsecureAPI = SecureAPI diff --git a/servant-auth/servant-auth-swagger/test/Spec.hs b/servant-auth/servant-auth-swagger/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth-swagger/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-auth/servant-auth/.ghci b/servant-auth/servant-auth/.ghci new file mode 100644 index 00000000..ae927ec4 --- /dev/null +++ b/servant-auth/servant-auth/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -idoctest/ghci-wrapper/src diff --git a/servant-auth/servant-auth/CHANGELOG.md b/servant-auth/servant-auth/CHANGELOG.md new file mode 100644 index 00000000..cb1d5b8f --- /dev/null +++ b/servant-auth/servant-auth/CHANGELOG.md @@ -0,0 +1,20 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) +and this project adheres to [PVP Versioning](https://pvp.haskell.org/). + +## [Unreleased] + +## [0.4.0.0] - 2020-10-06 + +- Support for GHC 8.10 by @domenkozar +- Support servant 0.18 by @domenkozar +- Move `ToJWT/FromJWT` from servant-auth-server + +## [0.3.2.0] - 2018-06-18 + +### Added +- Support for GHC 8.4 by @phadej +- Changelog by @domenkozar diff --git a/servant-auth/servant-auth/LICENSE b/servant-auth/servant-auth/LICENSE new file mode 100644 index 00000000..302f74f7 --- /dev/null +++ b/servant-auth/servant-auth/LICENSE @@ -0,0 +1,31 @@ +Copyright Julian K. Arni (c) 2015 + +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 Julian K. Arni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/servant-auth/servant-auth/Setup.hs b/servant-auth/servant-auth/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/servant-auth/servant-auth/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth/servant-auth/servant-auth.cabal b/servant-auth/servant-auth/servant-auth.cabal new file mode 100644 index 00000000..61b3a6a4 --- /dev/null +++ b/servant-auth/servant-auth/servant-auth.cabal @@ -0,0 +1,46 @@ +name: servant-auth +version: 0.4.0.0 +synopsis: Authentication combinators for servant +description: This package provides an @Auth@ combinator for 'servant'. This combinator + allows using different authentication schemes in a straightforward way, + and possibly in conjunction with one another. + . + 'servant-auth' additionally provides concrete authentication schemes, such + as Basic Access Authentication, JSON Web Tokens, and Cookies. + . + For more details on how to use this, see the . +category: Web, Servant, Authentication +homepage: http://github.com/haskell-servant/servant/servant-auth#readme +bug-reports: https://github.com/haskell-servant/servant/issues +author: Julian K. Arni +maintainer: jkarni@gmail.com +copyright: (c) Julian K. Arni +license: BSD-3-Clause +license-file: LICENSE +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1 +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/haskell-servant/servant + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DefaultSignatures DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs KindSignatures MultiParamTypeClasses OverloadedStrings RankNTypes ScopedTypeVariables TypeFamilies TypeOperators + ghc-options: -Wall + build-depends: + base >= 4.10 && < 4.16 + , aeson >= 1.3.1.1 && < 1.6 + , jose >= 0.7.0.0 && < 0.9 + , lens >= 4.16.1 && < 5.1 + , servant >= 0.15 && < 0.19 + , text >= 1.2.3.0 && < 1.3 + , unordered-containers >= 0.2.9.0 && < 0.3 + exposed-modules: + Servant.Auth + Servant.Auth.JWT + default-language: Haskell2010 diff --git a/servant-auth/servant-auth/src/Servant/Auth.hs b/servant-auth/servant-auth/src/Servant/Auth.hs new file mode 100644 index 00000000..1ada6fe2 --- /dev/null +++ b/servant-auth/servant-auth/src/Servant/Auth.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Servant.Auth where + +import Data.Proxy (Proxy(..)) +import Servant.API ((:>)) +import Servant.Links (HasLink (..)) + +-- * Authentication + +-- | @Auth [auth1, auth2] val :> api@ represents an API protected *either* by +-- @auth1@ or @auth2@ +data Auth (auths :: [*]) val + +-- | A @HasLink@ instance for @Auth@ +instance HasLink sub => HasLink (Auth (tag :: [*]) value :> sub) where +#if MIN_VERSION_servant(0,14,0) + type MkLink (Auth (tag :: [*]) value :> sub) a = MkLink sub a + toLink toA _ = toLink toA (Proxy :: Proxy sub) +#else + type MkLink (Auth (tag :: [*]) value :> sub) = MkLink sub + toLink _ = toLink (Proxy :: Proxy sub) +#endif + +-- ** Combinators + +-- | A JSON Web Token (JWT) in the the Authorization header: +-- +-- @Authorization: Bearer \@ +-- +-- Note that while the token is signed, it is not encrypted. Therefore do not +-- keep in it any information you would not like the client to know. +-- +-- JWTs are described in IETF's +data JWT + +-- | A cookie. The content cookie itself is a JWT. Another cookie is also used, +-- the contents of which are expected to be send back to the server in a +-- header, for XSRF protection. +data Cookie + + +-- We could use 'servant''s BasicAuth, but then we don't get control over the +-- documentation, and we'd have to polykind everything. (Also, we don't +-- currently depend on servant!) +-- +-- | Basic Auth. +data BasicAuth + +-- | Login via a form. +data FormLogin form diff --git a/servant-auth/servant-auth/src/Servant/Auth/JWT.hs b/servant-auth/servant-auth/src/Servant/Auth/JWT.hs new file mode 100644 index 00000000..f02494ba --- /dev/null +++ b/servant-auth/servant-auth/src/Servant/Auth/JWT.hs @@ -0,0 +1,33 @@ +module Servant.Auth.JWT where + +import Control.Lens ((^.)) +import qualified Crypto.JWT as Jose +import Data.Aeson (FromJSON, Result (..), ToJSON, fromJSON, + toJSON) +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T + + +-- This should probably also be from ClaimSet +-- +-- | How to decode data from a JWT. +-- +-- The default implementation assumes the data is stored in the unregistered +-- @dat@ claim, and uses the @FromJSON@ instance to decode value from there. +class FromJWT a where + decodeJWT :: Jose.ClaimsSet -> Either T.Text a + default decodeJWT :: FromJSON a => Jose.ClaimsSet -> Either T.Text a + decodeJWT m = case HM.lookup "dat" (m ^. Jose.unregisteredClaims) of + Nothing -> Left "Missing 'dat' claim" + Just v -> case fromJSON v of + Error e -> Left $ T.pack e + Success a -> Right a + +-- | How to encode data from a JWT. +-- +-- The default implementation stores data in the unregistered @dat@ claim, and +-- uses the type's @ToJSON@ instance to encode the data. +class ToJWT a where + encodeJWT :: a -> Jose.ClaimsSet + default encodeJWT :: ToJSON a => a -> Jose.ClaimsSet + encodeJWT a = Jose.addClaim "dat" (toJSON a) Jose.emptyClaimsSet \ No newline at end of file diff --git a/servant-auth/servant-auth/test/Spec.hs b/servant-auth/servant-auth/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-auth/servant-auth/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-client-core/CHANGELOG.md b/servant-client-core/CHANGELOG.md index 9dfcadc3..ce5f1573 100644 --- a/servant-client-core/CHANGELOG.md +++ b/servant-client-core/CHANGELOG.md @@ -1,6 +1,84 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/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.18.3 +------ + +### Significant changes + +- Add response header support to UVerb (#1420) + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring`, `hspec`, `base64-bytestring` and `QuickCheck` dependencies. + +0.18.2 +------ + +### Significant changes + +- Support `Fragment` combinator. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions +- Loosen bound on base16-bytestring + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + + +0.17 +---- + +### Significant changes + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + 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. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + 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. + +### Other changes + +- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204) + + For `Verb`s with response `Headers`, the implementation didn't check + for the content-type of the response. Now it does. + +- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197) +- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238) + 0.16 ---- @@ -166,7 +244,7 @@ - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers - of a web application live in, we also have `hoistClient` for changing the monad + of a web application live, we also have `hoistClient` for changing the monad in which *client functions* live. Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 3faf65bb..3d630110 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-client-core -version: 0.16 +version: 0.18.3 synopsis: Core functionality and class for client function generation for servant APIs category: Servant, Web @@ -10,19 +10,14 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause 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: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 - , GHCJS == 8.4 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 + , GHCJS ==8.6.0.1 extra-source-files: CHANGELOG.md @@ -55,13 +50,13 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.9 && < 4.14 - , bytestring >= 0.10.8.1 && < 0.11 + base >= 4.9 && < 4.16 + , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , text >= 1.2.3.0 && < 1.3 , transformers >= 0.5.2.0 && < 0.6 - , template-haskell >= 2.11.1.0 && < 2.16 + , template-haskell >= 2.11.1.0 && < 2.18 if !impl(ghc >= 8.2) build-depends: @@ -69,20 +64,21 @@ library -- Servant dependencies build-depends: - servant >= 0.16 && <0.17 + servant >= 0.18.3 && <0.19 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - aeson >= 1.4.1.0 && < 1.5 + aeson >= 1.4.1.0 && < 1.6 , base-compat >= 0.10.5 && < 0.12 - , base64-bytestring >= 1.0.0.1 && < 1.1 + , base64-bytestring >= 1.0.0.1 && < 1.3 , exceptions >= 0.10.0 && < 0.11 , free >= 5.1 && < 5.2 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , safe >= 0.3.17 && < 0.4 + , sop-core >= 0.4.0.0 && < 0.6 hs-source-dirs: src default-language: Haskell2010 @@ -104,11 +100,11 @@ test-suite spec , base-compat , servant-client-core - -- Additonal dependencies + -- Additional dependencies build-depends: deepseq >= 1.4.2.0 && < 1.5 - , hspec >= 2.6.0 && < 2.8 - , QuickCheck >= 2.12.6.1 && < 2.14 + , hspec >= 2.6.0 && < 2.9 + , QuickCheck >= 2.12.6.1 && < 2.15 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && <2.8 + hspec-discover:hspec-discover >= 2.6.0 && <2.9 diff --git a/servant-client-core/src/Servant/Client/Core.hs b/servant-client-core/src/Servant/Client/Core.hs index e23724b3..4e6667f5 100644 --- a/servant-client-core/src/Servant/Client/Core.hs +++ b/servant-client-core/src/Servant/Client/Core.hs @@ -18,6 +18,8 @@ module Servant.Client.Core -- * Client generation clientIn , HasClient(..) + , foldMapUnion + , matchUnion -- * Request , Request diff --git a/servant-client-core/src/Servant/Client/Core/BasicAuth.hs b/servant-client-core/src/Servant/Client/Core/BasicAuth.hs index 64862688..3856b6ce 100644 --- a/servant-client-core/src/Servant/Client/Core/BasicAuth.hs +++ b/servant-client-core/src/Servant/Client/Core/BasicAuth.hs @@ -9,8 +9,6 @@ module Servant.Client.Core.BasicAuth ( import Data.ByteString.Base64 (encode) -import Data.Monoid - ((<>)) import Data.Text.Encoding (decodeUtf8) import Servant.API.BasicAuth diff --git a/servant-client-core/src/Servant/Client/Core/HasClient.hs b/servant-client-core/src/Servant/Client/Core/HasClient.hs index e26c1cdc..514a0c9e 100644 --- a/servant-client-core/src/Servant/Client/Core/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/HasClient.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,56 +9,84 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802 +#define HAS_TYPE_ERROR +#endif + module Servant.Client.Core.HasClient ( clientIn, HasClient (..), EmptyClient (..), + foldMapUnion, + matchUnion, ) where import Prelude () import Prelude.Compat +import Control.Arrow + (left, (+++)) import Control.Monad (unless) +import qualified Data.ByteString as BS +import Data.ByteString.Builder + (toLazyByteString) import qualified Data.ByteString.Lazy as BL +import Data.Either + (partitionEithers) import Data.Foldable (toList) import Data.List (foldl') -import Data.Proxy - (Proxy (Proxy)) import Data.Sequence (fromList) import qualified Data.Text as T import Network.HTTP.Media (MediaType, matches, parseAccept, (//)) +import qualified Data.Sequence as Seq +import Data.SOP.BasicFunctors + (I (I), (:.:) (Comp)) +import Data.SOP.Constraint + (All) +import Data.SOP.NP + (NP (..), cpure_NP) +import Data.SOP.NS + (NS (S)) import Data.String (fromString) import Data.Text (Text, pack) +import Data.Proxy + (Proxy (Proxy)) import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.HTTP.Types + (Status) import qualified Network.HTTP.Types as H import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData, BuildHeadersTo (..), Capture', CaptureAll, Description, - EmptyAPI, FramingRender (..), FramingUnrender (..), + EmptyAPI, Fragment, FramingRender (..), FramingUnrender (..), FromSourceIO (..), Header', Headers (..), HttpVersion, IsSecure, MimeRender (mimeRender), - MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag, - QueryParam', QueryParams, QueryParamForm', Raw, ReflectMethod (..), RemoteHost, - ReqBody', SBoolI, Stream, StreamBody', Summary, ToHttpApiData, ToForm (..), - ToSourceIO (..), Vault, Verb, NoContentVerb, WithNamedContext, - contentType, getHeadersHList, getResponse, toQueryParam, - toUrlPiece) + MimeUnrender (mimeUnrender), NoContent (NoContent), + NoContentVerb, QueryFlag, QueryParam', QueryParams, QueryParamForm', Raw, + ReflectMethod (..), RemoteHost, ReqBody', SBoolI, Stream, + StreamBody', Summary, ToForm (..), ToHttpApiData, ToSourceIO (..), Vault, + Verb, WithNamedContext, WithStatus (..), contentType, getHeadersHList, + getResponse, toEncodedUrlPiece, toUrlPiece) import Servant.API.ContentTypes - (contentTypes) + (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender)) +import Servant.API.TypeLevel (FragmentUnique, AtLeastOneFragment) import Servant.API.Modifiers (FoldRequired, RequiredArgument, foldRequiredArgument) +import Servant.API.UVerb + (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion) import Servant.Client.Core.Auth import Servant.Client.Core.BasicAuth @@ -288,6 +318,92 @@ instance {-# OVERLAPPING #-} hoistClientMonad _ _ f ma = f ma +data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus + deriving (Eq, Show) + +class UnrenderResponse (cts :: [*]) (a :: *) where + unrenderResponse :: Seq.Seq H.Header -> BL.ByteString -> Proxy cts + -> [Either (MediaType, String) a] + +instance {-# OVERLAPPABLE #-} AllMimeUnrender cts a => UnrenderResponse cts a where + unrenderResponse _ body = map parse . allMimeUnrender + where parse (mediaType, parser) = left ((,) mediaType) (parser body) + +instance {-# OVERLAPPING #-} forall cts a h . (UnrenderResponse cts a, BuildHeadersTo h) + => UnrenderResponse cts (Headers h a) where + unrenderResponse hs body = (map . fmap) setHeaders . unrenderResponse hs body + where + setHeaders :: a -> Headers h a + setHeaders x = Headers x (buildHeadersTo (toList hs)) + +instance {-# OVERLAPPING #-} UnrenderResponse cts a + => UnrenderResponse cts (WithStatus n a) where + unrenderResponse hs body = (map . fmap) WithStatus . unrenderResponse hs body + +instance {-# OVERLAPPING #-} + ( RunClient m, + contentTypes ~ (contentType ': otherContentTypes), + -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem + -- allow this in instance types as of 8.8.3.) + as ~ (a ': as'), + AllMime contentTypes, + ReflectMethod method, + All (UnrenderResponse contentTypes) as, + All HasStatus as, HasStatuses as', + Unique (Statuses as) + ) => + HasClient m (UVerb method contentTypes as) + where + type Client m (UVerb method contentTypes as) = m (Union as) + + clientWithRoute _ _ request = do + let accept = Seq.fromList . allMime $ Proxy @contentTypes + -- offering to accept all mime types listed in the api gives best compatibility. eg., + -- we might not own the server implementation, and the server may choose to support + -- only part of the api. + + method = reflectMethod $ Proxy @method + acceptStatus = statuses (Proxy @as) + response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept} + responseContentType <- checkContentTypeHeader response + unless (any (matches responseContentType) accept) $ do + throwClientError $ UnsupportedContentType responseContentType response + + let status = responseStatusCode response + body = responseBody response + headers = responseHeaders response + res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) headers body + case res of + Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response + Right x -> return x + where + -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the + -- failures it encountered along the way + -- TODO; better name, rewrite haddocs. + tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs) + tryParsers _ Nil = Left [ClientNoMatchingStatus] + tryParsers status (Comp x :* xs) + | status == statusOf (Comp x) = + case partitionEithers x of + (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs + (_, (res : _)) -> Right . inject . I $ res + | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for + (ClientStatusMismatch :) +++ S $ tryParsers status xs + + -- | Given a list of types, parses the given response body as each type + mimeUnrenders :: + forall cts xs. + All (UnrenderResponse cts) xs => + Proxy cts -> + Seq.Seq H.Header -> + BL.ByteString -> + NP ([] :.: Either (MediaType, String)) xs + mimeUnrenders ctp headers body = cpure_NP + (Proxy @(UnrenderResponse cts)) + (Comp . unrenderResponse headers body $ ctp) + + hoistClientMonad _ _ nt s = nt s + instance {-# OVERLAPPABLE #-} ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method, FramingUnrender framing, FromSourceIO chunk a @@ -441,7 +557,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire (Proxy :: Proxy mods) add (maybe req add) mparam where add :: a -> Request - add param = appendToQueryString pname (Just $ toQueryParam param) req + add param = appendToQueryString pname (Just $ encodeQueryParam param) req pname :: Text pname = pack $ symbolVal (Proxy :: Proxy sym) @@ -449,6 +565,9 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api, SBoolI (FoldRequire hoistClientMonad pm _ f cl = \arg -> hoistClientMonad pm (Proxy :: Proxy api) f (cl arg) +encodeQueryParam :: ToHttpApiData a => a -> BS.ByteString +encodeQueryParam = BL.toStrict . toLazyByteString . toEncodedUrlPiece + -- | If you use a 'QueryParams' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument, a list of values of the type specified @@ -490,7 +609,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient m api) ) where pname = pack $ symbolVal (Proxy :: Proxy sym) - paramlist' = map (Just . toQueryParam) paramlist + paramlist' = map (Just . encodeQueryParam) paramlist hoistClientMonad pm _ f cl = \as -> hoistClientMonad pm (Proxy :: Proxy api) f (cl as) @@ -708,6 +827,33 @@ instance ( HasClient m api hoistClientMonad pm _ f cl = \authreq -> hoistClientMonad pm (Proxy :: Proxy api) f (cl authreq) +-- | Ignore @'Fragment'@ in client functions. +-- See for more details. +-- +-- Example: +-- +-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book] +-- > +-- > myApi :: Proxy MyApi +-- > myApi = Proxy +-- > +-- > getBooks :: ClientM [Book] +-- > getBooks = client myApi +-- > -- then you can just use "getBooksBy" to query that endpoint. +-- > -- 'getBooks' for all books. +#ifdef HAS_TYPE_ERROR +instance (AtLeastOneFragment api, FragmentUnique (Fragment a :> api), HasClient m api +#else +instance ( HasClient m api +#endif + ) => HasClient m (Fragment a :> api) where + + type Client m (Fragment a :> api) = Client m api + + clientWithRoute pm _ = clientWithRoute pm (Proxy :: Proxy api) + + hoistClientMonad pm _ = hoistClientMonad pm (Proxy :: Proxy api) + -- * Basic Authentication instance HasClient m api => HasClient m (BasicAuth realm usr :> api) where diff --git a/servant-client-core/src/Servant/Client/Core/Reexport.hs b/servant-client-core/src/Servant/Client/Core/Reexport.hs index 81e5d432..7d2aa980 100644 --- a/servant-client-core/src/Servant/Client/Core/Reexport.hs +++ b/servant-client-core/src/Servant/Client/Core/Reexport.hs @@ -5,6 +5,8 @@ module Servant.Client.Core.Reexport ( -- * HasClient HasClient(..) + , foldMapUnion + , matchUnion -- * Response (for @Raw@) , Response diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index ca5f855c..50d1bb9d 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Request.hs @@ -36,8 +36,6 @@ import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS -import Data.Semigroup - ((<>)) import qualified Data.Sequence as Seq import Data.Text (Text) @@ -149,13 +147,13 @@ appendToPath :: Text -> Request -> Request appendToPath p req = req { requestPath = requestPath req <> "/" <> toEncodedUrlPiece p } -appendToQueryString :: Text -- ^ param name - -> Maybe Text -- ^ param value +appendToQueryString :: Text -- ^ param name + -> Maybe BS.ByteString -- ^ param value -> Request -> Request appendToQueryString pname pvalue req = req { requestQueryString = requestQueryString req - Seq.|> (encodeUtf8 pname, encodeUtf8 <$> pvalue)} + Seq.|> (encodeUtf8 pname, pvalue)} addHeader :: ToHttpApiData a => HeaderName -> a -> Request -> Request addHeader name val req diff --git a/servant-client-core/src/Servant/Client/Core/RunClient.hs b/servant-client-core/src/Servant/Client/Core/RunClient.hs index fb5eb957..4487f05c 100644 --- a/servant-client-core/src/Servant/Client/Core/RunClient.hs +++ b/servant-client-core/src/Servant/Client/Core/RunClient.hs @@ -7,6 +7,7 @@ -- | Types for possible backends to run client-side `Request` queries module Servant.Client.Core.RunClient ( RunClient (..), + runRequest, RunStreamingClient (..), ClientF (..), ) where @@ -14,6 +15,8 @@ module Servant.Client.Core.RunClient ( import Prelude () import Prelude.Compat +import Network.HTTP.Types.Status + (Status) import Control.Monad.Free (Free (..), liftF) @@ -22,10 +25,15 @@ import Servant.Client.Core.Request import Servant.Client.Core.Response class Monad m => RunClient m where - -- | How to make a request. - runRequest :: Request -> m Response + -- | How to make a request, with an optional list of status codes to not throw exceptions + -- for (default: [200..299]). + runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response throwClientError :: ClientError -> m a +-- | How to make a request. +runRequest :: RunClient m => Request -> m Response +runRequest = runRequestAcceptStatus Nothing + class RunClient m => RunStreamingClient m where withStreamingRequest :: Request -> (StreamingResponse -> IO a) -> m a @@ -41,6 +49,7 @@ data ClientF a | Throw ClientError deriving (Functor) +-- TODO: honour the accept-status argument. instance ClientF ~ f => RunClient (Free f) where - runRequest req = liftF (RunRequest req id) + runRequestAcceptStatus _ req = liftF (RunRequest req id) throwClientError = liftF . Throw diff --git a/servant-client-ghcjs/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal index 5308525e..2a2a68ad 100644 --- a/servant-client-ghcjs/servant-client-ghcjs.cabal +++ b/servant-client-ghcjs/servant-client-ghcjs.cabal @@ -15,7 +15,7 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com @@ -39,7 +39,7 @@ library build-depends: base >=4.11 && <4.12 - , bytestring >=0.10 && <0.11 + , bytestring >=0.10 && <0.12 , case-insensitive >=1.2.0.0 && <1.3.0.0 , containers >=0.5 && <0.7 , exceptions >=0.8 && <0.11 diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 02f7bd85..02f27369 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,6 +1,92 @@ [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.18.3 +------ + +### Significant changes + +- Add response header support to UVerb (#1420) + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring`, `hspec`, `http-client` and `QuickCheck` dependencies. + +0.18.2 +------ + +### Significant changes + +- Support `Fragment` combinator. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + + +0.17 +---- + +### Significant changes + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + 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. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + 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. + +- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255) + + 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. + +### Other changes + +- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204) + + For `Verb`s with response `Headers`, the implementation didn't check + for the content-type of the response. Now it does. + +- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197) +- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238) + + + 0.16.0.1 -------- @@ -150,7 +236,7 @@ - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers - of a web application live in, we also have `hoistClient` for changing the monad + of a web application live, we also have `hoistClient` for changing the monad in which *client functions* live. Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index dd7356f1..3ca4c88a 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-client -version: 0.16.0.1 +version: 0.18.3 synopsis: Automatic derivation of querying functions for servant category: Servant, Web @@ -14,18 +14,14 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause 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: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 + , GHCJS ==8.6.0.1 extra-source-files: CHANGELOG.md @@ -45,8 +41,8 @@ library -- 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.14 - , bytestring >= 0.10.8.1 && < 0.11 + base >= 4.9 && < 4.16 + , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , mtl >= 2.2.2 && < 2.3 @@ -62,14 +58,14 @@ library -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends: - servant == 0.16.* - , servant-client-core >= 0.16 && <0.16.1 + servant == 0.18.* + , servant-client-core >= 0.18.3 && <0.18.4 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.12 - , http-client >= 0.5.13.1 && < 0.7 + , http-client >= 0.5.13.1 && < 0.8 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 , exceptions >= 0.10.0 && < 0.11 @@ -77,7 +73,7 @@ library , monad-control >= 1.0.2.3 && < 1.1 , semigroupoids >= 5.3.1 && < 5.4 , transformers-base >= 0.4.5.2 && < 0.5 - , transformers-compat >= 0.6.2 && < 0.7 + , transformers-compat >= 0.6.2 && < 0.8 hs-source-dirs: src default-language: Haskell2010 @@ -87,6 +83,8 @@ test-suite spec type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded "-with-rtsopts=-T -N2" default-language: Haskell2010 + if impl(ghcjs) + buildable: False hs-source-dirs: test main-is: Spec.hs other-modules: @@ -113,6 +111,7 @@ test-suite spec , kan-extensions , servant-client , servant-client-core + , sop-core , stm , text , transformers @@ -120,19 +119,19 @@ test-suite spec , wai , warp - -- Additonal dependencies + -- Additional dependencies build-depends: entropy >= 0.4.1.3 && < 0.5 - , hspec >= 2.6.0 && < 2.8 + , hspec >= 2.6.0 && < 2.9 , HUnit >= 1.6.0.0 && < 1.7 , network >= 2.8.0.0 && < 3.2 - , QuickCheck >= 2.12.6.1 && < 2.14 - , servant == 0.16.* - , servant-server == 0.16.* + , QuickCheck >= 2.12.6.1 && < 2.15 + , servant == 0.18.* + , servant-server == 0.18.* , tdigest >= 0.2 && < 0.3 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && < 2.8 + hspec-discover:hspec-discover >= 2.6.0 && < 2.9 test-suite readme type: exitcode-stdio-1.0 @@ -141,3 +140,5 @@ test-suite readme build-tool-depends: markdown-unlit:markdown-unlit ghc-options: -pgmL markdown-unlit default-language: Haskell2010 + if impl(ghcjs) + buildable: False diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index c25c8a93..a2c6864d 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -46,15 +46,13 @@ import qualified Data.ByteString.Lazy as BSL import Data.Either (either) import Data.Foldable - (toList) + (foldl',toList) import Data.Functor.Alt (Alt (..)) import Data.Maybe (maybe, maybeToList) import Data.Proxy (Proxy (..)) -import Data.Semigroup - ((<>)) import Data.Sequence (fromList) import Data.String @@ -65,7 +63,7 @@ import GHC.Generics import Network.HTTP.Media (renderHeader) import Network.HTTP.Types - (hContentType, renderQuery, statusCode) + (hContentType, renderQuery, statusCode, urlEncode, Status) import Servant.Client.Core import qualified Network.HTTP.Client as Client @@ -155,14 +153,14 @@ instance Alt ClientM where a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req request <- case cookieJar' of @@ -183,8 +181,11 @@ performRequest req = do let status = Client.responseStatus response status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ - throwError $ mkFailureResponse burl req ourResponse + goodStatus = case acceptStatus of + Nothing -> status_code >= 200 && status_code < 300 + Just good -> status `elem` good + unless goodStatus $ do + throwError $ mkFailureResponse burl req ourResponse return ourResponse where requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString) @@ -237,7 +238,7 @@ defaultMakeClientRequest burl r = Client.defaultRequest , Client.path = BSL.toStrict $ fromString (baseUrlPath burl) <> toLazyByteString (requestPath r) - , Client.queryString = renderQuery True . toList $ requestQueryString r + , Client.queryString = buildQueryString . toList $ requestQueryString r , Client.requestHeaders = maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers , Client.requestBody = body @@ -288,6 +289,13 @@ defaultMakeClientRequest burl r = Client.defaultRequest Http -> False Https -> True + -- Query string builder which does not do any encoding + buildQueryString = ("?" <>) . foldl' addQueryParam mempty + + addQueryParam qs (k, v) = + qs <> (if BS.null qs then mempty else "&") <> urlEncode True k <> foldMap ("=" <>) v + + catchConnectionError :: IO a -> IO (Either ClientError a) catchConnectionError action = catch (Right <$> action) $ \e -> diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 2f5a1cb7..6a1b235d 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -47,7 +47,7 @@ import Data.Time.Clock (getCurrentTime) import GHC.Generics import Network.HTTP.Types - (statusCode) + (Status, statusCode) import qualified Network.HTTP.Client as Client @@ -112,7 +112,7 @@ instance Alt ClientM where a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError instance RunStreamingClient ClientM where @@ -130,14 +130,14 @@ withClientM cm env k = -- streaming response types ('SourceT', 'Conduit', pipes 'Proxy' or 'Machine'). -- For those you have to use 'withClientM'. -- --- /Note:/ we 'force' the result, so the likehood of accidentally leaking a +-- /Note:/ we 'force' the result, so the likelihood of accidentally leaking a -- connection is smaller. Use with care. -- runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a) runClientM cm env = withClientM cm env (evaluate . force) -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do -- TODO: should use Client.withResponse here too ClientEnv m burl cookieJar' createClientRequest <- ask let clientRequest = createClientRequest burl req @@ -165,10 +165,14 @@ performRequest req = do let status = Client.responseStatus response status_code = statusCode status ourResponse = clientResponseToResponse id response - unless (status_code >= 200 && status_code < 300) $ + goodStatus = case acceptStatus of + Nothing -> status_code >= 200 && status_code < 300 + Just good -> status `elem` good + unless goodStatus $ do throwError $ mkFailureResponse burl req ourResponse return ourResponse +-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above). performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a performWithStreamingRequest req k = do m <- asks manager diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 6f385010..198c6462 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -23,19 +24,32 @@ import Prelude.Compat import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Monad + (join) import Control.Monad.Error.Class (throwError) import Data.Aeson +import Data.ByteString + (ByteString) +import Data.ByteString.Builder + (byteString) +import qualified Data.ByteString.Lazy as LazyByteString import Data.Char (chr, isPrint) import Data.Monoid () import Data.Proxy +import Data.SOP +import Data.Text + (Text) +import qualified Data.Text as Text +import Data.Text.Encoding + (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP import Network.Socket -import qualified Network.Wai as Wai +import qualified Network.Wai as Wai import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) @@ -45,12 +59,14 @@ import Web.FormUrlEncoded import Servant.API ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, - BasicAuthData (..), Capture, CaptureAll, - DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header, - Headers, JSON, NoContent (NoContent), Post, QueryFlag, - QueryParam, QueryParams, Raw, ReqBody, addHeader) + BasicAuthData (..), Capture, CaptureAll, DeleteNoContent, + EmptyAPI, FormUrlEncoded, Fragment, FromHttpApiData (..), Get, Header, Headers, + JSON, MimeRender (mimeRender), MimeUnrender (mimeUnrender), + NoContent (NoContent), PlainText, Post, QueryFlag, QueryParam, + QueryParams, Raw, ReqBody, StdMethod (GET), ToHttpApiData (..), UVerb, Union, + WithStatus (WithStatus), addHeader) import Servant.Client -import qualified Servant.Client.Core.Auth as Auth +import qualified Servant.Client.Core.Auth as Auth import Servant.Server import Servant.Server.Experimental.Auth import Servant.Test.ComprehensiveAPI @@ -63,7 +79,7 @@ _ = client comprehensiveAPIWithoutStreaming data Person = Person { _name :: String , _age :: Integer - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Read, Generic) instance ToJSON Person instance FromJSON Person @@ -74,6 +90,15 @@ instance FromForm Person instance Arbitrary Person where arbitrary = Person <$> arbitrary <*> arbitrary +instance MimeRender PlainText Person where + mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show + +instance MimeUnrender PlainText Person where + mimeUnrender _ = + -- This does not handle any errors, but it should be fine for tests + Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict + + alice :: Person alice = Person "Alice" 42 @@ -90,8 +115,13 @@ type Api = :<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person] :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person + -- This endpoint makes use of a 'Raw' server because it is not currently + -- possible to handle arbitrary binary query param values with + -- @servant-server@ + :<|> "param-binary" :> QueryParam "payload" UrlEncodedByteString :> Raw :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool + :<|> "fragment" :> Fragment String :> Get '[JSON] Person :<|> "rawSuccess" :> Raw :<|> "rawSuccessPassHeaders" :> Raw :<|> "rawFailure" :> Raw @@ -102,9 +132,16 @@ type Api = ReqBody '[JSON] [(String, [Rational])] :> Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) + :<|> "uverb-headers" :> UVerb 'GET '[JSON] '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ] :<|> "deleteContentType" :> DeleteNoContent :<|> "redirectWithCookie" :> Raw :<|> "empty" :> EmptyAPI + :<|> "uverb-success-or-redirect" :> + Capture "bool" Bool :> + UVerb 'GET '[PlainText] '[WithStatus 200 Person, + WithStatus 301 Text] + :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person] + api :: Proxy Api api = Proxy @@ -116,16 +153,23 @@ getCapture :: String -> ClientM Person getCaptureAll :: [String] -> ClientM [Person] getBody :: Person -> ClientM Person getQueryParam :: Maybe String -> ClientM Person +getQueryParamBinary :: Maybe UrlEncodedByteString -> HTTP.Method -> ClientM Response getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool +getFragment :: ClientM Person 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])]) getRespHeaders :: ClientM (Headers TestHeaders Bool) +getUVerbRespHeaders :: ClientM (Union '[ WithStatus 200 (Headers TestHeaders Bool), WithStatus 204 String ]) getDeleteContentType :: ClientM NoContent getRedirectWithCookie :: HTTP.Method -> ClientM Response +uverbGetSuccessOrRedirect :: Bool + -> ClientM (Union '[WithStatus 200 Person, + WithStatus 301 Text]) +uverbGetCreated :: ClientM (Union '[WithStatus 201 Person]) getRoot :<|> getGet @@ -134,16 +178,21 @@ getRoot :<|> getCaptureAll :<|> getBody :<|> getQueryParam + :<|> getQueryParamBinary :<|> getQueryParams :<|> getQueryFlag + :<|> getFragment :<|> getRawSuccess :<|> getRawSuccessPassHeaders :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders + :<|> getUVerbRespHeaders :<|> getDeleteContentType :<|> getRedirectWithCookie - :<|> EmptyClient = client api + :<|> EmptyClient + :<|> uverbGetSuccessOrRedirect + :<|> uverbGetCreated = client api server :: Application server = serve api ( @@ -157,16 +206,30 @@ server = serve api ( Just "alice" -> return alice Just n -> throwError $ ServerError 400 (n ++ " not found") "" [] Nothing -> throwError $ ServerError 400 "missing parameter" "" []) + :<|> const (Tagged $ \request respond -> + respond . maybe (Wai.responseLBS HTTP.notFound404 [] "Missing: payload") + (Wai.responseLBS HTTP.ok200 [] . LazyByteString.fromStrict) + . join + . lookup "payload" + $ Wai.queryString request + ) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return + :<|> return alice :<|> (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) + :<|> (pure . Z . I . WithStatus $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "") - :<|> emptyServer) + :<|> emptyServer + :<|> (\shouldRedirect -> if shouldRedirect + then respond (WithStatus @301 ("redirecting" :: Text)) + else respond (WithStatus @200 alice )) + :<|> respond (WithStatus @201 carol) + ) type FailApi = "get" :> Raw @@ -266,3 +329,12 @@ pathGen = fmap NonEmpty path filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] + +newtype UrlEncodedByteString = UrlEncodedByteString { unUrlEncodedByteString :: ByteString } + +instance ToHttpApiData UrlEncodedByteString where + toEncodedUrlPiece = byteString . HTTP.urlEncode True . unUrlEncodedByteString + toUrlPiece = decodeUtf8 . HTTP.urlEncode True . unUrlEncodedByteString + +instance FromHttpApiData UrlEncodedByteString where + parseUrlPiece = pure . UrlEncodedByteString . HTTP.urlDecode True . encodeUtf8 diff --git a/servant-client/test/Servant/FailSpec.hs b/servant-client/test/Servant/FailSpec.hs index baec72b6..0abf3e73 100644 --- a/servant-client/test/Servant/FailSpec.hs +++ b/servant-client/test/Servant/FailSpec.hs @@ -21,8 +21,6 @@ import Prelude () import Prelude.Compat import Data.Monoid () -import Data.Semigroup - ((<>)) import qualified Network.HTTP.Types as HTTP import Test.Hspec diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index 272b607c..6b9f3bd0 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -freduction-depth=100 #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} @@ -21,30 +22,33 @@ import Prelude () import Prelude.Compat import Control.Arrow - (left) + ((+++), left) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (newTVar, readTVar) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL import Data.Foldable (forM_, toList) import Data.Maybe (listToMaybe) import Data.Monoid () -import qualified Network.HTTP.Client as C -import qualified Network.HTTP.Types as HTTP +import Data.Text + (Text) +import qualified Network.HTTP.Client as C +import qualified Network.HTTP.Types as HTTP import Test.Hspec import Test.Hspec.QuickCheck import Test.HUnit import Test.QuickCheck import Servant.API - (NoContent (NoContent), getHeaders) + (NoContent (NoContent), WithStatus (WithStatus), getHeaders, Headers(..)) import Servant.Client -import qualified Servant.Client.Core.Request as Req -import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) -import Servant.Test.ComprehensiveAPI +import qualified Servant.Client.Core.Request as Req import Servant.ClientTestUtils +import Servant.Test.ComprehensiveAPI -- This declaration simply checks that all instances are in place. _ = client comprehensiveAPIWithoutStreaming @@ -91,6 +95,11 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Left (FailureResponse _ r) <- runClient (getQueryParam (Just "bob")) baseUrl responseStatusCode r `shouldBe` HTTP.Status 400 "bob not found" + it "Servant.API.QueryParam binary data" $ \(_, baseUrl) -> do + let payload = BS.pack [0, 1, 2, 4, 8, 16, 32, 64, 128] + apiCall = getQueryParamBinary (Just $ UrlEncodedByteString payload) HTTP.methodGet + (show +++ responseBody) <$> runClient apiCall baseUrl `shouldReturn` Right (BL.fromStrict payload) + it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do left show <$> runClient (getQueryParams []) baseUrl `shouldReturn` Right [] left show <$> runClient (getQueryParams ["alice", "bob"]) baseUrl @@ -100,6 +109,8 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do left show <$> runClient (getQueryFlag flag) baseUrl `shouldReturn` Right flag + it "Servant.API.Fragment" $ \(_, baseUrl) -> do + left id <$> runClient getFragment baseUrl `shouldReturn` Right alice it "Servant.API.Raw on success" $ \(_, baseUrl) -> do res <- runClient (getRawSuccess HTTP.methodGet) baseUrl case res of @@ -123,6 +134,15 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + it "Returns headers on UVerb requests" $ \(_, baseUrl) -> do + res <- runClient getUVerbRespHeaders baseUrl + case res of + Left e -> assertFailure $ show e + Right val -> case matchUnion val of + Just (WithStatus val' :: WithStatus 200 (Headers TestHeaders Bool)) + -> getHeaders val' `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] + Nothing -> assertFailure "unexpected alternative of union" + it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings cj <- atomically . newTVar $ C.createCookieJar [] @@ -151,3 +171,23 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do result <- left show <$> runClient (getMultiple cap num flag body) baseUrl return $ result === Right (cap, num, flag, body) + + context "With a route that can either return success or redirect" $ do + it "Redirects when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting") + + it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice) + + context "with a route that uses uverb but only has a single response" $ + it "returns the expected response" $ \(_, baseUrl) -> do + eitherResponse <- runClient (uverbGetCreated) baseUrl + case eitherResponse of + Left clientError -> fail $ show clientError + Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol) diff --git a/servant-conduit/servant-conduit.cabal b/servant-conduit/servant-conduit.cabal index 4aec51d8..ccb94c9e 100644 --- a/servant-conduit/servant-conduit.cabal +++ b/servant-conduit/servant-conduit.cabal @@ -1,7 +1,6 @@ cabal-version: >=1.10 name: servant-conduit -version: 0.15 -x-revision: 1 +version: 0.15.1 synopsis: Servant Stream support for conduit. category: Servant, Web, Enumerator @@ -11,18 +10,13 @@ description: Servant Stream support for conduit. homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2018-2019 Servant Contributors build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 extra-source-files: CHANGELOG.md @@ -35,12 +29,12 @@ library exposed-modules: Servant.Conduit build-depends: base >=4.9 && <5 - , bytestring >=0.10.8.1 && <0.11 + , bytestring >=0.10.8.1 && <0.12 , conduit >=1.3.1 && <1.4 , mtl >=2.2.2 && <2.3 , resourcet >=1.2.2 && <1.3 - , servant >=0.15 && <0.17 - , unliftio-core >=0.1.2.0 && <0.2 + , servant >=0.15 && <0.19 + , unliftio-core >=0.1.2.0 && <0.3 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -60,8 +54,8 @@ test-suite example , resourcet , servant , servant-conduit - , servant-server >=0.15 && <0.17 - , servant-client >=0.15 && <0.17 + , servant-server >=0.15 && <0.19 + , servant-client >=0.15 && <0.19 , wai >=3.2.1.2 && <3.3 , warp >=3.2.25 && <3.4 , http-client diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index 5744be55..e357ef6c 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,6 +1,77 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.11.9 +------ + +### Significant changes + +- Use Capture Description if available (#1423). + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring` and `lens` dependencies. + +0.11.8 +------ + +### Significant changes + +- Support `Fragment` combinator. + +0.11.7 +------ + +### Significant changes + +- Add instance for ToSample NonEmpty + +### Other changes + +- Bump "tested-with" ghc versions +- Fix servant-docs code sample in README + +0.11.5 +---- + + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + 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. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + 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. + +- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241) + + 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. + +- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194) + 0.11.4 ------ diff --git a/servant-docs/README.md b/servant-docs/README.md index 9c2d6e37..231e6be4 100644 --- a/servant-docs/README.md +++ b/servant-docs/README.md @@ -2,24 +2,56 @@ ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) -Generate API docs for your *servant* webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**. +Generate API docs for your _servant_ webservice. Feel free to also take a look at [servant-pandoc](https://github.com/mpickering/servant-pandoc) which uses this package to target a broad range of output formats using the excellent **pandoc**. ## Example See [here](https://github.com/haskell-servant/servant/blob/master/servant-docs/example/greet.md) for the output of the following program. -``` haskell +```haskell {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -import Data.Proxy -import Data.Text +import Data.Aeson (FromJSON, ToJSON) +import Data.Proxy (Proxy (..)) +import Data.String.Conversions (cs) +import Data.Text (Text) +import GHC.Generics (Generic) +import Servant.API + ( (:<|>), + (:>), + Capture, + Delete, + Get, + JSON, + MimeRender, + PlainText, + Post, + QueryParam, + ReqBody, + mimeRender, + ) import Servant.Docs + ( API, + DocCapture (..), + DocQueryParam (..), + ParamKind (..), + ToCapture, + ToParam, + ToSample, + docs, + markdown, + singleSample, + toCapture, + toParam, + toSamples, + ) -- our type for a Greeting message data Greet = Greet { _msg :: Text } @@ -29,6 +61,7 @@ data Greet = Greet { _msg :: Text } -- 'MimeRender' instance for 'JSON'. instance FromJSON Greet instance ToJSON Greet +instance ToSample () -- We can also implement 'MimeRender' explicitly for additional formats. instance MimeRender PlainText Greet where @@ -36,8 +69,7 @@ instance MimeRender PlainText Greet where -- we provide a sample value for the 'Greet' type instance ToSample Greet where - toSample = Just g - + toSamples _ = singleSample g where g = Greet "Hello, haskeller!" instance ToParam (QueryParam "capital" Bool) where @@ -45,6 +77,7 @@ instance ToParam (QueryParam "capital" Bool) where DocQueryParam "capital" ["true", "false"] "Get the greeting message in uppercase (true) or not (false). Default is false." + Normal instance ToCapture (Capture "name" Text) where toCapture _ = DocCapture "name" "name of the person to greet" @@ -55,8 +88,8 @@ instance ToCapture (Capture "greetid" Text) where -- API specification type TestApi = "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON,PlainText] Greet - :<|> "greet" :> RQBody '[JSON] Greet :> Post '[JSON] Greet - :<|> "delete" :> Capture "greetid" Text :> Delete '[] () + :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet + :<|> "delete" :> Capture "greetid" Text :> Delete '[JSON] () testApi :: Proxy TestApi testApi = Proxy diff --git a/servant-docs/example/greet.hs b/servant-docs/example/greet.hs index ec36c7ca..68edfa5e 100644 --- a/servant-docs/example/greet.hs +++ b/servant-docs/example/greet.hs @@ -75,7 +75,7 @@ intro2 = DocIntro "This title is below the last" -- API specification type TestApi = -- GET /hello/:name?capital={true, false} returns a Greet as JSON or PlainText - "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet + "hello" :> Capture "name" Text :> Header "X-Num-Fairies" Int :> QueryParam "capital" Bool :> Get '[JSON, PlainText] Greet -- POST /greet with a Greet as JSON in the request body, -- returns a Greet as JSON @@ -93,9 +93,9 @@ testApi = Proxy extra :: ExtraInfo TestApi extra = extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $ - defAction & headers <>~ ["unicorns"] + defAction & headers <>~ [("X-Num-Unicorns", "1")] & notes <>~ [ DocNote "Title" ["This is some text"] - , DocNote "Second secton" ["And some more"] + , DocNote "Second section" ["And some more"] ] -- Generate the data that lets us have API docs. This @@ -109,4 +109,4 @@ docsGreet :: API docsGreet = docsWith defaultDocOptions [intro1, intro2] extra testApi main :: IO () -main = putStrLn $ markdown docsGreet +main = putStrLn $ markdownWith (defRenderingOptions { _renderCurlBasePath = Just "http://localhost:80" }) docsGreet diff --git a/servant-docs/example/greet.md b/servant-docs/example/greet.md index 322d3c28..1283f628 100644 --- a/servant-docs/example/greet.md +++ b/servant-docs/example/greet.md @@ -51,13 +51,22 @@ You'll also note that multiple intros are possible. "Hello, haskeller" ``` +### Sample Request: + +```bash +curl -XPOST \ + -H "Content-Type: application/json;charset=utf-8" \ + -d "\"HELLO, HASKELLER\"" \ + http://localhost:80/greet +``` + ## DELETE /greet/:greetid ### Title This is some text -### Second secton +### Second section And some more @@ -67,7 +76,7 @@ And some more ### Headers: -- This endpoint is sensitive to the value of the **unicorns** HTTP header. +- This endpoint is sensitive to the value of the **X-Num-Unicorns** HTTP header. ### Response: @@ -85,12 +94,24 @@ And some more ``` +### Sample Request: + +```bash +curl -XDELETE \ + -H "X-Num-Unicorns: 1" \ + http://localhost:80/greet/:greetid +``` + ## GET /hello/:name ### Captures: - *name*: name of the person to greet +### Headers: + +- This endpoint is sensitive to the value of the **X-Num-Fairies** HTTP header. + ### GET Parameters: - capital @@ -120,3 +141,13 @@ And some more ```javascript "Hello, haskeller" ``` + +### Sample Request: + +```bash +curl -XGET \ + -H "X-Num-Fairies: 1729" \ + http://localhost:80/hello/:name +``` + + diff --git a/servant-docs/golden/comprehensive.md b/servant-docs/golden/comprehensive.md index 5bb7c4e9..9584d499 100644 --- a/servant-docs/golden/comprehensive.md +++ b/servant-docs/golden/comprehensive.md @@ -52,11 +52,11 @@ ``` -## GET /capture/:foo +## GET /capture/:bar ### Captures: -- *foo*: Capture foo Int +- *bar*: example description ### Response: @@ -182,6 +182,28 @@ ``` +## GET /fragment + +### Fragment: + +- *foo*: Fragment Int + +### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json;charset=utf-8` + - `application/json` + +- Example (`application/json;charset=utf-8`, `application/json`): + +```javascript + +``` + ## GET /get-int ### Response: diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index 72896d72..64829f3e 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-docs -version: 0.11.4 +version: 0.11.9 synopsis: generate API docs for your servant webservice category: Servant, Web @@ -13,18 +13,13 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause 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: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 extra-source-files: CHANGELOG.md @@ -46,25 +41,25 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.9 && < 4.14 - , bytestring >= 0.10.8.1 && < 0.11 + base >= 4.9 && < 4.16 + , bytestring >= 0.10.8.1 && < 0.12 , text >= 1.2.3.0 && < 1.3 -- Servant dependencies build-depends: - servant >= 0.15 && <0.17 + servant >= 0.18 && <0.19 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: - aeson >= 1.4.1.0 && < 1.5 + aeson >= 1.4.1.0 && < 1.6 , aeson-pretty >= 0.8.5 && < 0.9 , base-compat >= 0.10.5 && < 0.12 , case-insensitive >= 1.2.0.11 && < 1.3 , hashable >= 1.2.7.0 && < 1.4 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 - , lens >= 4.17 && < 4.19 + , lens >= 4.17 && < 5.1 , string-conversions >= 0.4.0.1 && < 0.5 , universe-base >= 1.1.1 && < 1.2 , unordered-containers >= 0.2.9.0 && < 0.3 @@ -105,10 +100,9 @@ test-suite spec , servant-docs , string-conversions - -- Additonal dependencies + -- Additional dependencies build-depends: - tasty >= 1.1.0.4 && < 1.3, + tasty >= 1.1.0.4 && < 1.5, tasty-golden >= 2.3.2 && < 2.4, tasty-hunit >= 0.10.0.1 && < 0.11, transformers >= 0.5.2.0 && < 0.6 - diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index c2cca1ca..9991aec5 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -25,17 +25,15 @@ import Control.Applicative import Control.Arrow (second) import Control.Lens - (makeLenses, mapped, over, traversed, view, (%~), (&), (.~), - (<>~), (^.), (|>)) + (makeLenses, mapped, each, over, set, to, toListOf, traversed, view, + _1, (%~), (&), (.~), (<>~), (^.), (|>)) import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Lazy.Char8 as LBSC import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.CaseInsensitive as CI import Data.Foldable - (toList) -import Data.Foldable - (fold) + (fold, toList) import Data.Hashable (Hashable) import Data.HashMap.Strict @@ -53,19 +51,20 @@ import Data.Ord (comparing) import Data.Proxy (Proxy (Proxy)) -import Data.Semigroup - (Semigroup (..)) import Data.String.Conversions (cs) import Data.Text (Text, unpack) import GHC.Generics + (Generic, Rep, K1(K1), M1(M1), U1(U1), V1, + (:*:)((:*:)), (:+:)(L1, R1)) +import qualified GHC.Generics as G import GHC.TypeLits import Servant.API import Servant.API.ContentTypes import Servant.API.TypeLevel -import qualified Data.Universe.Helpers as U +import qualified Data.Universe.Helpers as U import qualified Data.HashMap.Strict as HM import qualified Data.Text as T @@ -162,6 +161,20 @@ data DocQueryParam = DocQueryParam , _paramKind :: ParamKind } deriving (Eq, Ord, Show) +-- | A type to represent fragment. Holds the name of the fragment and its description. +-- +-- Write a 'ToFragment' instance for your fragment types. +data DocFragment = DocFragment + { _fragSymbol :: String -- type supplied + , _fragDesc :: String -- user supplied + } deriving (Eq, Ord, Show) + +-- | There should be at most one 'Fragment' per API endpoint. +-- So here we are keeping the first occurrence. +combineFragment :: Maybe DocFragment -> Maybe DocFragment -> Maybe DocFragment +Nothing `combineFragment` mdocFragment = mdocFragment +Just docFragment `combineFragment` _ = Just docFragment + -- | An introductory paragraph for your documentation. You can pass these to -- 'docsWithIntros'. data DocIntro = DocIntro @@ -282,8 +295,9 @@ defResponse = Response data Action = Action { _authInfo :: [DocAuthentication] -- user supplied info , _captures :: [DocCapture] -- type collected + user supplied info - , _headers :: [Text] -- type collected + , _headers :: [HTTP.Header] -- type collected , _params :: [DocQueryParam] -- type collected + user supplied info + , _fragment :: Maybe DocFragment -- type collected + user supplied info , _notes :: [DocNote] -- user supplied , _mxParams :: [(String, [DocQueryParam])] -- type collected + user supplied info , _rqtypes :: [M.MediaType] -- type collected @@ -297,8 +311,9 @@ data Action = Action -- As such, we invent a non-commutative, left associative operation -- 'combineAction' to mush two together taking the response from the very left. combineAction :: Action -> Action -> Action -Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' = - Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp') +Action a c h p f n m ts body resp + `combineAction` Action a' c' h' p' f' n' m' ts' body' resp' = + Action (a <> a') (c <> c') (h <> h') (p <> p') (f `combineFragment` f') (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'. @@ -306,10 +321,10 @@ Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' bod -- Tweakable with lenses. -- -- >>> defAction --- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}} +-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 200, _respTypes = [], _respBody = [], _respHeaders = []}} -- -- >>> defAction & response.respStatus .~ 201 --- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}} +-- Action {_authInfo = [], _captures = [], _headers = [], _params = [], _fragment = Nothing, _notes = [], _mxParams = [], _rqtypes = [], _rqbody = [], _response = Response {_respStatus = 201, _respTypes = [], _respBody = [], _respHeaders = []}} -- defAction :: Action defAction = @@ -317,6 +332,7 @@ defAction = [] [] [] + Nothing [] [] [] @@ -340,12 +356,14 @@ data ShowContentTypes = AllContentTypes -- ^ For each example, show each conten -- -- @since 0.11.1 data RenderingOptions = RenderingOptions - { _requestExamples :: !ShowContentTypes + { _requestExamples :: !ShowContentTypes -- ^ How many content types to display for request body examples? - , _responseExamples :: !ShowContentTypes + , _responseExamples :: !ShowContentTypes -- ^ How many content types to display for response body examples? - , _notesHeading :: !(Maybe String) + , _notesHeading :: !(Maybe String) -- ^ Optionally group all 'notes' together under a common heading. + , _renderCurlBasePath :: !(Maybe String) + -- ^ Optionally render example curl requests under a common base path (e.g. `http://localhost:80`). } deriving (Show) -- | Default API generation options. @@ -357,9 +375,10 @@ data RenderingOptions = RenderingOptions -- @since 0.11.1 defRenderingOptions :: RenderingOptions defRenderingOptions = RenderingOptions - { _requestExamples = AllContentTypes - , _responseExamples = AllContentTypes - , _notesHeading = Nothing + { _requestExamples = AllContentTypes + , _responseExamples = AllContentTypes + , _notesHeading = Nothing + , _renderCurlBasePath = Nothing } -- gimme some lenses @@ -369,6 +388,7 @@ makeLenses ''API makeLenses ''Endpoint makeLenses ''DocCapture makeLenses ''DocQueryParam +makeLenses ''DocFragment makeLenses ''DocIntro makeLenses ''DocNote makeLenses ''Response @@ -395,9 +415,9 @@ docsWithOptions p = docsFor p (defEndpoint, defAction) -- > extra :: ExtraInfo TestApi -- > extra = -- > extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete)) $ --- > defAction & headers <>~ ["unicorns"] +-- > defAction & headers <>~ [("X-Num-Unicorns", 1)] -- > & notes <>~ [ DocNote "Title" ["This is some text"] --- > , DocNote "Second secton" ["And some more"] +-- > , DocNote "Second section" ["And some more"] -- > ] extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint) @@ -490,7 +510,7 @@ samples = map ("",) -- | Default sample Generic-based inputs/outputs. defaultSamples :: forall a. (Generic a, GToSample (Rep a)) => Proxy a -> [(Text, a)] -defaultSamples _ = second to <$> gtoSamples (Proxy :: Proxy (Rep a)) +defaultSamples _ = second G.to <$> gtoSamples (Proxy :: Proxy (Rep a)) -- | @'ToSample'@ for Generics. -- @@ -588,6 +608,15 @@ class ToCapture c where class ToAuthInfo a where toAuthInfo :: Proxy a -> DocAuthentication +-- | The class that helps us get documentation for URL fragments. +-- +-- Example of an instance: +-- +-- > instance ToFragment (Fragment a) where +-- > toFragment _ = DocFragment "fragment" "fragment description" +class ToFragment t where + toFragment :: Proxy t -> DocFragment + -- | Generate documentation in Markdown format for -- the given 'API'. -- @@ -617,7 +646,7 @@ markdown = markdownWith defRenderingOptions -- -- @since 0.11.1 markdownWith :: RenderingOptions -> API -> String -markdownWith RenderingOptions{..} api = unlines $ +markdownWith RenderingOptions{..} api = unlines $ introsStr (api ^. apiIntros) ++ (concatMap (uncurry printEndpoint) . sort . HM.toList $ api ^. apiEndpoints) @@ -628,10 +657,12 @@ markdownWith RenderingOptions{..} api = unlines $ notesStr (action ^. notes) ++ authStr (action ^. authInfo) ++ capturesStr (action ^. captures) ++ - headersStr (action ^. headers) ++ + headersStr (toListOf (headers . each . _1 . to (T.pack . BSC.unpack . CI.original)) action) ++ paramsStr meth (action ^. params) ++ + fragmentStr (action ^. fragment) ++ rqbodyStr (action ^. rqtypes) (action ^. rqbody) ++ responseStr (action ^. response) ++ + maybe [] (curlStr endpoint (action ^. headers) (action ^. rqbody)) _renderCurlBasePath ++ [] where str = "## " ++ BSC.unpack meth @@ -731,6 +762,14 @@ markdownWith RenderingOptions{..} api = unlines $ where values = param ^. paramValues + fragmentStr :: Maybe DocFragment -> [String] + fragmentStr Nothing = [] + fragmentStr (Just frag) = + [ "### Fragment:", "" + , "- *" ++ (frag ^. fragSymbol) ++ "*: " ++ (frag ^. fragDesc) + , "" + ] + rqbodyStr :: [M.MediaType] -> [(Text, M.MediaType, ByteString)]-> [String] rqbodyStr [] [] = [] rqbodyStr types s = @@ -779,7 +818,6 @@ markdownWith RenderingOptions{..} api = unlines $ ("text", "css") -> "css" (_, _) -> "" - contentStr mime_type body = "" : "```" <> markdownForType mime_type : @@ -804,6 +842,36 @@ markdownWith RenderingOptions{..} api = unlines $ xs -> formatBodies _responseExamples xs + curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String] + curlStr endpoint hdrs reqBodies basePath = + [ "### Sample Request:" + , "" + , "```bash" + , "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\" + ] <> + maybe [] pure mbMediaTypeStr <> + headersStrs <> + maybe [] pure mbReqBodyStr <> + [ " " ++ basePath ++ showPath (endpoint ^. path) + , "```" + , "" + ] + + where escapeQuotes :: String -> String + escapeQuotes = concatMap $ \c -> case c of + '\"' -> "\\\"" + _ -> [c] + mbReqBody = listToMaybe reqBodies + mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody + headersStrs = mkHeaderStr <$> hdrs + mbReqBodyStr = mkReqBodyStr <$> mbReqBody + mkMediaTypeStr (_, media_type, _) = + " -H \"Content-Type: " ++ show media_type ++ "\" \\" + mkHeaderStr (hdrName, hdrVal) = + " -H \"" ++ escapeQuotes (cs (CI.original hdrName)) ++ ": " ++ + escapeQuotes (cs hdrVal) ++ "\" \\" + mkReqBodyStr (_, _, body) = " -d \"" ++ escapeQuotes (cs body) ++ "\" \\" + -- * Instances -- | The generated docs for @a ':<|>' b@ just appends the docs @@ -827,7 +895,7 @@ instance HasDocs EmptyAPI where -- | @"books" :> 'Capture' "isbn" Text@ will appear as -- @/books/:isbn@ in the docs. instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api) - => HasDocs (Capture' mods sym a :> api) where + => HasDocs (Capture' '[] sym a :> api) where docsFor Proxy (endpoint, action) = docsFor subApiP (endpoint', action') @@ -839,6 +907,28 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api) endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint symP = Proxy :: Proxy sym +instance (KnownSymbol descr, KnownSymbol sym, HasDocs api) + => HasDocs (Capture' (Description descr ': mods) sym a :> api) where + + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint', action') + + where subApiP = Proxy :: Proxy api + + docCapture = DocCapture (symbolVal symP) (symbolVal descrP) + action' = over captures (|> docCapture) action + endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint + descrP = Proxy :: Proxy descr + symP = Proxy :: Proxy sym + +instance {-# OVERLAPPABLE #-} HasDocs (Capture' mods sym a :> api) + => HasDocs (Capture' (mod ': mods) sym a :> api) where + + docsFor Proxy = + docsFor apiP + + where apiP = Proxy :: Proxy (Capture' mods sym a :> api) + -- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as -- @/books/:isbn@ in the docs. @@ -920,14 +1010,17 @@ instance {-# OVERLAPPING #-} status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a -instance (KnownSymbol sym, HasDocs api) +instance (ToHttpApiData a, ToSample a, KnownSymbol sym, HasDocs api) => HasDocs (Header' mods sym a :> api) where docsFor Proxy (endpoint, action) = docsFor subApiP (endpoint, action') where subApiP = Proxy :: Proxy api - action' = over headers (|> headername) action - headername = T.pack $ symbolVal (Proxy :: Proxy sym) + action' = over headers (|> (headerName, headerVal)) action + headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy sym) + headerVal = case toSample (Proxy :: Proxy a) of + Just x -> cs $ toHeader x + Nothing -> "" instance (KnownSymbol sym, ToParam (QueryParam' mods sym a), HasDocs api) => HasDocs (QueryParam' mods sym a :> api) where @@ -964,7 +1057,6 @@ instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api) -- require a 'ToSample a' instance instance (ToForm a, ToSample a, HasDocs api) => HasDocs (QueryParamForm' mods a :> api) where - docsFor Proxy (endpoint, action) = docsFor subApiP (endpoint, action') @@ -980,6 +1072,15 @@ instance (ToForm a, ToSample a, HasDocs api) , _paramKind = Normal } +instance (ToFragment (Fragment a), HasDocs api) + => HasDocs (Fragment a :> api) where + docsFor Proxy (endpoint, action) = + docsFor subApiP (endpoint, action') + where subApiP = Proxy :: Proxy api + fragmentP = Proxy :: Proxy (Fragment a) + action' = set fragment (Just (toFragment fragmentP)) action + + instance HasDocs Raw where docsFor _proxy (endpoint, action) _ = single endpoint action @@ -1084,6 +1185,7 @@ instance (ToSample a, ToSample b, ToSample c, ToSample d, ToSample e, ToSample f instance ToSample a => ToSample (Maybe a) instance (ToSample a, ToSample b) => ToSample (Either a b) instance ToSample a => ToSample [a] +instance ToSample a => ToSample (NonEmpty a) -- ToSample instances for Control.Applicative types instance ToSample a => ToSample (Const a b) diff --git a/servant-docs/src/Servant/Docs/Internal/Pretty.hs b/servant-docs/src/Servant/Docs/Internal/Pretty.hs index 568ce26d..ac82c945 100644 --- a/servant-docs/src/Servant/Docs/Internal/Pretty.hs +++ b/servant-docs/src/Servant/Docs/Internal/Pretty.hs @@ -18,6 +18,7 @@ import Data.Proxy import Network.HTTP.Media ((//)) import Servant.API +import Servant.API.Verbs -- | PrettyJSON content type. data PrettyJSON @@ -46,6 +47,24 @@ type family Pretty (api :: k) :: k where Pretty (Put cs r) = Put (Pretty cs) r Pretty (Delete cs r) = Delete (Pretty cs) r Pretty (Patch cs r) = Patch (Pretty cs) r + Pretty (GetPartialContent cs r) = GetPartialContent (Pretty cs) r + Pretty (PutResetContent cs r) = PutResetContent (Pretty cs) r + Pretty (PatchResetContent cs r) = PatchResetContent (Pretty cs) r + Pretty (DeleteResetContent cs r) = DeleteResetContent (Pretty cs) r + Pretty (PostResetContent cs r) = PostResetContent (Pretty cs) r + Pretty (GetResetContent cs r) = GetResetContent (Pretty cs) r + Pretty (PutNonAuthoritative cs r) = PutNonAuthoritative (Pretty cs) r + Pretty (PatchNonAuthoritative cs r) = PatchNonAuthoritative (Pretty cs) r + Pretty (DeleteNonAuthoritative cs r) = DeleteNonAuthoritative (Pretty cs) r + Pretty (PostNonAuthoritative cs r) = PostNonAuthoritative (Pretty cs) r + Pretty (GetNonAuthoritative cs r) = GetNonAuthoritative (Pretty cs) r + Pretty (PutAccepted cs r) = PutAccepted (Pretty cs) r + Pretty (PatchAccepted cs r) = PatchAccepted (Pretty cs) r + Pretty (DeleteAccepted cs r) = DeleteAccepted (Pretty cs) r + Pretty (PostAccepted cs r) = PostAccepted (Pretty cs) r + Pretty (GetAccepted cs r) = GetAccepted (Pretty cs) r + Pretty (PutCreated cs r) = PutCreated (Pretty cs) r + Pretty (PostCreated cs r) = PostCreated (Pretty cs) r Pretty (ReqBody cs r) = ReqBody (Pretty cs) r Pretty (JSON ': xs) = PrettyJSON ': xs Pretty (x ': xs) = x ': Pretty xs diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index d53f53dc..f8a35ebb 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -60,6 +60,8 @@ instance ToCapture (Capture "foo" Int) where toCapture _ = DocCapture "foo" "Capture foo Int" instance ToCapture (CaptureAll "foo" Int) where toCapture _ = DocCapture "foo" "Capture all foo Int" +instance ToFragment (Fragment Int) where + toFragment _ = DocFragment "foo" "Fragment Int" -- * specs @@ -132,8 +134,10 @@ spec = describe "Servant.Docs" $ do it "mentions headers" $ do md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." - it "contains response samples" $ - md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}" + it "contains response samples - dt1field1" $ + md `shouldContain` "\"dt1field1\":\"field 1\"" + it "contains response samples - dt1field2" $ + md `shouldContain` "\"dt1field2\":13" it "contains request body samples" $ md `shouldContain` "17" diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 64fc579b..4c3302ed 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -1,6 +1,93 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md) [Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.15.4 +------ + +### Significant changes + +- Documentation improvements. + +### Other changes + +- Support GHC-9.0.1. +- Bump `lens` and `hspec` dependencies. + +0.15.3 +------ + +### Significant changes + +- Support `Fragment` combinator. + +0.15.2 +------ + +* Support `servant-0.18`. + +0.15.1 +------ + +* Support `servant-0.17` + +0.15 +---- + +- *servant-foreign* Add support so `HasForeign` can be implemented for + `MultipartForm` from [`servant-multipart`](http://hackage.haskell.org/package/servant-multipart) + [#1035](https://github.com/haskell-servant/servant/pull/1035) + +- Drop support for GHC older than 8.0 + [#1008](https://github.com/haskell-servant/servant/pull/1008) + [#1009](https://github.com/haskell-servant/servant/pull/1009) + + +0.11.1 +------ + +- Add missing `Semigroup` instances + +0.11 +---- + +### Breaking changes + +- *servant* Add `Servant.API.Modifiers` + ([#873](https://github.com/haskell-servant/servant/pull/873)) +- Make foreign client Header arguments have the representation of 'Maybe' in those languages + ([#843](https://github.com/haskell-servant/servant/pull/843)) + +0.10.2 +------ + +### Changes + +* Add instances for `Description` and `Summary` combinators + ([#767](https://github.com/haskell-servant/servant/pull/767)) +* Derive Data for all types + ([#809](https://github.com/haskell-servant/servant/pull/809)) + +0.10.1 +------ + +### Changes + +* Don't drop samples in `HasDocs ReqBody` instance + ([#755](https://github.com/haskell-servant/servant/pull/755/files)). + *Breaking change in an `Internal` module*. + +0.10 +---- + +### Breaking changes + +* Do not apply JavaScript specific mangling to the names. + ([#191](https://github.com/haskell-servant/servant/issues/191)) + +0.7.1 +----- + +* Support GHC 8.0 0.15 ---- diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 1d85c132..d438ff38 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -1,7 +1,6 @@ cabal-version: >=1.10 name: servant-foreign -version: 0.15 -x-revision: 1 +version: 0.15.4 synopsis: Helpers for generating clients for servant APIs in any programming language category: Servant, Web @@ -16,18 +15,13 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2015-2019 Servant Contributors build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 extra-source-files: CHANGELOG.md @@ -47,18 +41,18 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.9 && < 4.14 + base >= 4.9 && < 4.16 , text >= 1.2.3.0 && < 1.3 -- Servant dependencies build-depends: - servant >=0.15 && <0.17 + servant >=0.18 && <0.19 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.12 - , lens >= 4.17 && < 4.19 + , lens >= 4.17 && < 5.1 , http-types >= 0.12.2 && < 0.13 hs-source-dirs: src @@ -78,10 +72,9 @@ test-suite spec , servant , servant-foreign - -- Additonal dependencies + -- Additional dependencies build-depends: - hspec >= 2.6.0 && <2.8 - + hspec >= 2.6.0 && <2.9 build-tool-depends: - hspec-discover:hspec-discover >=2.6.0 && <2.8 + hspec-discover:hspec-discover >=2.6.0 && <2.9 default-language: Haskell2010 diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index aa1a5573..6c50889e 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -1,20 +1,32 @@ -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages. +-- +-- See documentation of 'HasForeignType' for a simple example. 'listFromAPI' returns a list of all your endpoints and their foreign types, given a mapping from Haskell types to foreign types (conventionally called `ftypes` below). module Servant.Foreign - ( ArgType(..) - , HeaderArg(..) - , QueryArg(..) + ( + -- * Main API + listFromAPI , Req(..) - , ReqBodyContentType(..) + , defReq + , HasForeignType(..) + , GenerateList(..) + , HasForeign(..) + , NoTypes + -- * Subtypes of 'Req' + , Url(..) + , Path , Segment(..) , SegmentType(..) - , Url(..) - -- aliases - , Path + , isCapture + , captureArg + , QueryArg(..) + , ArgType(..) + , HeaderArg(..) , Arg(..) , FunctionName(..) + , ReqBodyContentType(..) , PathSegment(..) - -- lenses + -- * Lenses , argName , argType , argPath @@ -30,7 +42,7 @@ module Servant.Foreign , queryArgName , queryArgType , headerArg - -- prisms + -- * Prisms , _PathSegment , _HeaderArg , _ReplaceHeaderArg @@ -39,16 +51,7 @@ module Servant.Foreign , _Normal , _Flag , _List - -- rest of it - , HasForeign(..) - , HasForeignType(..) - , GenerateList(..) - , NoTypes - , captureArg - , isCapture - , defReq - , listFromAPI - -- re-exports + -- * Re-exports , module Servant.API , module Servant.Foreign.Inflections ) where diff --git a/servant-foreign/src/Servant/Foreign/Inflections.hs b/servant-foreign/src/Servant/Foreign/Inflections.hs index 793ea36d..dcacb4cf 100644 --- a/servant-foreign/src/Servant/Foreign/Inflections.hs +++ b/servant-foreign/src/Servant/Foreign/Inflections.hs @@ -13,27 +13,37 @@ module Servant.Foreign.Inflections import Control.Lens hiding (cons) import qualified Data.Char as C -import Data.Monoid import Data.Text hiding (map) import Prelude hiding (head, tail) import Servant.Foreign.Internal +-- | Simply concat each part of the FunctionName together. +-- +-- @[ "get", "documents", "by", "id" ] → "getdocumentsbyid"@ +concatCase :: FunctionName -> Text +concatCase = view concatCaseL + concatCaseL :: Getter FunctionName Text concatCaseL = _FunctionName . to mconcat --- | Function name builder that simply concat each part together -concatCase :: FunctionName -> Text -concatCase = view concatCaseL +-- | Use the snake_case convention. +-- Each part is separated by a single underscore character. +-- +-- @[ "get", "documents", "by", "id" ] → "get_documents_by_id"@ +snakeCase :: FunctionName -> Text +snakeCase = view snakeCaseL snakeCaseL :: Getter FunctionName Text snakeCaseL = _FunctionName . to (intercalate "_") --- | Function name builder using the snake_case convention. --- each part is separated by a single underscore character. -snakeCase :: FunctionName -> Text -snakeCase = view snakeCaseL +-- | Use the camelCase convention. +-- The first part is lower case, every other part starts with an upper case character. +-- +-- @[ "get", "documents", "by", "id" ] → "getDocumentsById"@ +camelCase :: FunctionName -> Text +camelCase = view camelCaseL camelCaseL :: Getter FunctionName Text camelCaseL = _FunctionName . to convert @@ -42,8 +52,3 @@ camelCaseL = _FunctionName . to convert convert (p:ps) = mconcat $ p : map capitalize ps capitalize "" = "" capitalize name = C.toUpper (head name) `cons` tail name - --- | Function name builder using the CamelCase convention. --- each part begins with an upper case character. -camelCase :: FunctionName -> Text -camelCase = view camelCaseL diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 771f4442..ed4c451f 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -13,8 +13,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} --- | Generalizes all the data needed to make code generation work with --- arbitrary programming languages. module Servant.Foreign.Internal where import Prelude () @@ -25,8 +23,6 @@ import Control.Lens import Data.Data (Data) import Data.Proxy -import Data.Semigroup - (Semigroup) import Data.String import Data.Text import Data.Text.Encoding @@ -40,50 +36,75 @@ import Servant.API.Modifiers (RequiredArgument) import Servant.API.TypeLevel +-- | Canonical name of the endpoint, can be used to generate a function name. +-- +-- You can use the functions in "Servant.Foreign.Inflections", like 'Servant.Foreign.Inflections.camelCase' to transform to `Text`. newtype FunctionName = FunctionName { unFunctionName :: [Text] } deriving (Data, Show, Eq, Semigroup, Monoid, Typeable) makePrisms ''FunctionName +-- | See documentation of 'Arg' newtype PathSegment = PathSegment { unPathSegment :: Text } deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable) makePrisms ''PathSegment -data Arg f = Arg +-- | Maps a name to the foreign type that belongs to the annotated value. +-- +-- Used for header args, query args, and capture args. +data Arg ftype = Arg { _argName :: PathSegment - , _argType :: f } + -- ^ The name to be captured. + -- + -- Only for capture args it really denotes a path segment. + , _argType :: ftype + -- ^ Foreign type the associated value will have + } deriving (Data, Eq, Show, Typeable) makeLenses ''Arg -argPath :: Getter (Arg f) Text +argPath :: Getter (Arg ftype) Text argPath = argName . _PathSegment -data SegmentType f +data SegmentType ftype = Static PathSegment - -- ^ a static path segment. like "/foo" - | Cap (Arg f) - -- ^ a capture. like "/:userid" + -- ^ Static path segment. + -- + -- @"foo\/bar\/baz"@ + -- + -- contains the static segments @"foo"@, @"bar"@ and @"baz"@. + | Cap (Arg ftype) + -- ^ A capture. + -- + -- @"user\/{userid}\/name"@ + -- + -- would capture the arg @userid@ with type @ftype@. deriving (Data, Eq, Show, Typeable) makePrisms ''SegmentType -newtype Segment f = Segment { unSegment :: SegmentType f } +-- | A part of the Url’s path. +newtype Segment ftype = Segment { unSegment :: SegmentType ftype } deriving (Data, Eq, Show, Typeable) makePrisms ''Segment -isCapture :: Segment f -> Bool +-- | Whether a segment is a 'Cap'. +isCapture :: Segment ftype -> Bool isCapture (Segment (Cap _)) = True isCapture _ = False -captureArg :: Segment f -> Arg f +-- | Crashing Arg extraction from segment, TODO: remove +captureArg :: Segment ftype -> Arg ftype captureArg (Segment (Cap s)) = s captureArg _ = error "captureArg called on non capture" -type Path f = [Segment f] +-- TODO: remove, unnecessary indirection +type Path ftype = [Segment ftype] +-- | Type of a 'QueryArg'. data ArgType = Normal | Flag @@ -93,18 +114,41 @@ data ArgType makePrisms ''ArgType -data QueryArg f = QueryArg - { _queryArgName :: Arg f +-- | Url Query argument. +-- +-- Urls can contain query arguments, which is a list of key-value pairs. +-- In a typical url, query arguments look like this: +-- +-- @?foo=bar&alist[]=el1&alist[]=el2&aflag@ +-- +-- Each pair can be +-- +-- * @?foo=bar@: a plain key-val pair, either optional or required ('QueryParam') +-- * @?aflag@: a flag (no value, implicitly Bool with default `false` if it’s missing) ('QueryFlag') +-- * @?alist[]=el1&alist[]=el2@: list of values ('QueryParams') +-- +-- @_queryArgType@ will be set accordingly. +-- +-- For the plain key-val pairs ('QueryParam'), @_queryArgName@’s @ftype@ will be wrapped in a @Maybe@ if the argument is optional. +data QueryArg ftype = QueryArg + { _queryArgName :: Arg ftype + -- ^ Name and foreign type of the argument. Will be wrapped in `Maybe` if the query is optional and in a `[]` if the query is a list , _queryArgType :: ArgType + -- ^ one of normal/plain, list or flag } deriving (Data, Eq, Show, Typeable) makeLenses ''QueryArg -data HeaderArg f = HeaderArg - { _headerArg :: Arg f } +data HeaderArg ftype = + -- | The name of the header and the foreign type of its value. + HeaderArg + { _headerArg :: Arg ftype } + -- | Unused, will never be set. + -- + -- TODO: remove | ReplaceHeaderArg - { _headerArg :: Arg f + { _headerArg :: Arg ftype , _headerPattern :: Text } deriving (Data, Eq, Show, Typeable) @@ -113,28 +157,71 @@ makeLenses ''HeaderArg makePrisms ''HeaderArg -data Url f = Url - { _path :: Path f - , _queryStr :: [QueryArg f] +-- | Full endpoint url, with all captures and parameters +data Url ftype = Url + { _path :: Path ftype + -- ^ Url path, list of either static segments or captures + -- + -- @"foo\/{id}\/bar"@ + , _queryStr :: [QueryArg ftype] + -- ^ List of query args + -- + -- @"?foo=bar&a=b"@ + , _frag :: Maybe ftype + -- ^ Url fragment. + -- + -- Not sent to the HTTP server, so only useful for frontend matters (e.g. inter-page linking). + -- + -- @#fragmentText@ } deriving (Data, Eq, Show, Typeable) -defUrl :: Url f -defUrl = Url [] [] +defUrl :: Url ftype +defUrl = Url [] [] Nothing makeLenses ''Url +-- | See documentation of '_reqBodyContentType' data ReqBodyContentType = ReqBodyJSON | ReqBodyMultipart deriving (Data, Eq, Show, Read) -data Req f = Req - { _reqUrl :: Url f +-- | Full description of an endpoint in your API, generated by 'listFromAPI'. It should give you all the information needed to generate foreign language bindings. +-- +-- Every field containing @ftype@ will use the foreign type mapping specified via 'HasForeignType' (see its docstring on how to set that up). +-- +-- See https://docs.servant.dev/en/stable/tutorial/ApiType.html for accessible documentation of the possible content of an endpoint. +data Req ftype = Req + { _reqUrl :: Url ftype + -- ^ Full list of URL segments, including captures , _reqMethod :: HTTP.Method - , _reqHeaders :: [HeaderArg f] - , _reqBody :: Maybe f - , _reqReturnType :: Maybe f + -- ^ @\"GET\"@\/@\"POST\"@\/@\"PUT\"@\/… + , _reqHeaders :: [HeaderArg ftype] + -- ^ Headers required by this endpoint, with their type + , _reqBody :: Maybe ftype + -- ^ Foreign type of the expected request body ('ReqBody'), if any + , _reqReturnType :: Maybe ftype + -- ^ The foreign type of the response, if any , _reqFuncName :: FunctionName + -- ^ The URL segments rendered in a way that they can be easily concatenated into a canonical function name , _reqBodyContentType :: ReqBodyContentType + -- ^ The content type the request body is transferred as. + -- + -- This is a severe limitation of @servant-foreign@ currently, + -- as we only allow the content type to be `JSON` + -- no user-defined content types. ('ReqBodyMultipart' is not + -- actually implemented.) + -- + -- Thus, any routes looking like this will work: + -- + -- @"foo" :> Get '[JSON] Foo@ + -- + -- while routes like + -- + -- @"foo" :> Get '[MyFancyContentType] Foo@ + -- + -- will fail with an error like + -- + -- @• JSON expected in list '[MyFancyContentType]@ } deriving (Data, Eq, Show, Typeable) @@ -158,7 +245,7 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON -- > -- > -- Or for example in case of lists -- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where --- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) +-- > typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) -- -- Finally to generate list of information about all the endpoints for -- an API you create a function of a form: @@ -178,11 +265,16 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON class HasForeignType lang ftype a where typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype +-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations. data NoTypes -instance HasForeignType NoTypes NoContent ftype where +-- | Use if the foreign language does not have any types. +instance HasForeignType NoTypes NoContent a where typeFor _ _ _ = NoContent +-- | Implementation of the Servant framework types. +-- +-- Relevant instances: Everything containing 'HasForeignType'. class HasForeign lang ftype (api :: *) where type Foreign ftype api :: * foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api @@ -337,6 +429,16 @@ instance (HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang f { _argName = PathSegment "" , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (RequiredArgument mods a)) } +instance + (HasForeignType lang ftype (Maybe a), HasForeign lang ftype api) + => HasForeign lang ftype (Fragment a :> api) where + type Foreign ftype (Fragment a :> api) = Foreign ftype api + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $ + req & reqUrl . frag .~ Just argT + where + argT = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy (Maybe a)) + instance HasForeign lang ftype Raw where type Foreign ftype Raw = HTTP.Method -> Req ftype diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index e25b61f3..3632c071 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -11,11 +11,9 @@ module Servant.ForeignSpec where -import Data.Monoid - ((<>)) import Data.Proxy -import Servant.Test.ComprehensiveAPI import Servant.Foreign +import Servant.Test.ComprehensiveAPI import Servant.Types.SourceT (SourceT) @@ -103,6 +101,7 @@ listFromAPISpec = describe "listFromAPI" $ do { _reqUrl = Url [ Segment $ Static "test" ] [ QueryArg (Arg "flag" "boolX") Flag ] + Nothing , _reqMethod = "GET" , _reqHeaders = [HeaderArg $ Arg "header" "maybe listX of stringX"] , _reqBody = Nothing @@ -115,6 +114,7 @@ listFromAPISpec = describe "listFromAPI" $ do { _reqUrl = Url [ Segment $ Static "test" ] [ QueryArg (Arg "param" "maybe intX") Normal ] + Nothing , _reqMethod = "POST" , _reqHeaders = [] , _reqBody = Just "listX of stringX" @@ -137,8 +137,9 @@ listFromAPISpec = describe "listFromAPI" $ do shouldBe putReq $ defReq { _reqUrl = Url [ Segment $ Static "test" ] - -- Shoud this be |intX| or |listX of intX| ? + -- Should this be |intX| or |listX of intX| ? [ QueryArg (Arg "params" "listX of intX") List ] + Nothing , _reqMethod = "PUT" , _reqHeaders = [] , _reqBody = Just "stringX" @@ -152,6 +153,7 @@ listFromAPISpec = describe "listFromAPI" $ do [ Segment $ Static "test" , Segment $ Cap (Arg "id" "intX") ] [] + Nothing , _reqMethod = "DELETE" , _reqHeaders = [] , _reqBody = Nothing @@ -165,6 +167,7 @@ listFromAPISpec = describe "listFromAPI" $ do [ Segment $ Static "test" , Segment $ Cap (Arg "ids" "listX of intX") ] [] + Nothing , _reqMethod = "GET" , _reqHeaders = [] , _reqBody = Nothing diff --git a/servant-http-streams/CHANGELOG.md b/servant-http-streams/CHANGELOG.md index 19b1f6b1..40cbf44a 100644 --- a/servant-http-streams/CHANGELOG.md +++ b/servant-http-streams/CHANGELOG.md @@ -1,6 +1,82 @@ [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.18.3 +------ + +### Other changes + +- Support GHC-9.0.1. +- Fix test suite running in CI. +- Bump `bytestring` and `hspec` dependencies. + +0.18.2 +------ + +### Significant changes + +- Support `servant-client-core` 0.18.2. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + + +0.17 +---- + +### Significant changes + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + 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. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + 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. + +### Other changes + +- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204) + + For `Verb`s with response `Headers`, the implementation didn't check + for the content-type of the response. Now it does. + +- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197) +- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238) + + + 0.16.0.1 -------- diff --git a/servant-http-streams/servant-http-streams.cabal b/servant-http-streams/servant-http-streams.cabal index 5621ba67..2f86935c 100644 --- a/servant-http-streams/servant-http-streams.cabal +++ b/servant-http-streams/servant-http-streams.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-http-streams -version: 0.16 +version: 0.18.3 synopsis: Automatic derivation of querying functions for servant category: Servant, Web @@ -14,18 +14,13 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2019 Servant Contributors build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 extra-source-files: CHANGELOG.md @@ -43,8 +38,8 @@ library -- 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.14 - , bytestring >= 0.10.8.1 && < 0.11 + base >= 4.9 && < 4.16 + , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , deepseq >= 1.4.2.0 && < 1.5 , mtl >= 2.2.2 && < 2.3 @@ -59,8 +54,8 @@ library -- Servant dependencies. -- Strict dependency on `servant-client-core` as we re-export things. build-depends: - servant == 0.16.* - , servant-client-core >= 0.16 && <0.16.1 + servant == 0.18.* + , servant-client-core >= 0.18.3 && <0.18.4 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. @@ -71,7 +66,7 @@ library , http-media >= 0.7.1.3 && < 0.9 , io-streams >= 1.5.0.1 && < 1.6 , http-types >= 0.12.2 && < 0.13 - , http-common >= 0.8.2.0 && < 0.9 + , http-common >= 0.8.2.0 && < 0.8.3 , exceptions >= 0.10.0 && < 0.11 , kan-extensions >= 5.2 && < 5.3 , monad-control >= 1.0.2.3 && < 1.1 @@ -114,19 +109,19 @@ test-suite spec , wai , warp - -- Additonal dependencies + -- Additional dependencies build-depends: entropy >= 0.4.1.3 && < 0.5 - , hspec >= 2.6.0 && < 2.8 + , hspec >= 2.6.0 && < 2.9 , HUnit >= 1.6.0.0 && < 1.7 , network >= 2.8.0.0 && < 3.2 - , QuickCheck >= 2.12.6.1 && < 2.14 - , servant == 0.16.* - , servant-server == 0.16.* + , QuickCheck >= 2.12.6.1 && < 2.15 + , servant == 0.18.* + , servant-server == 0.18.* , tdigest >= 0.2 && < 0.3 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && < 2.8 + hspec-discover:hspec-discover >= 2.6.0 && < 2.9 test-suite readme type: exitcode-stdio-1.0 diff --git a/servant-http-streams/src/Servant/HttpStreams/Internal.hs b/servant-http-streams/src/Servant/HttpStreams/Internal.hs index 54c920bc..aef500b9 100644 --- a/servant-http-streams/src/Servant/HttpStreams/Internal.hs +++ b/servant-http-streams/src/Servant/HttpStreams/Internal.hs @@ -49,8 +49,6 @@ import Data.Maybe (maybeToList) import Data.Proxy (Proxy (..)) -import Data.Semigroup - ((<>)) import Data.Sequence (fromList) import Data.String @@ -141,7 +139,7 @@ instance Alt ClientM where a b = a `catchError` \_ -> b instance RunClient ClientM where - runRequest = performRequest + runRequestAcceptStatus = performRequest throwClientError = throwError instance RunStreamingClient ClientM where @@ -155,8 +153,8 @@ withClientM cm env k = let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm in f k -performRequest :: Request -> ClientM Response -performRequest req = do +performRequest :: Maybe [Status] -> Request -> ClientM Response +performRequest acceptStatus req = do ClientEnv burl conn <- ask let (req', body) = requestToClientRequest burl req x <- ClientM $ lift $ lift $ Codensity $ \k -> do @@ -165,7 +163,10 @@ performRequest req = do let sc = Client.getStatusCode res' lbs <- BSL.fromChunks <$> Streams.toList body' let res'' = clientResponseToResponse res' lbs - if sc >= 200 && sc < 300 + goodStatus = case acceptStatus of + Nothing -> sc >= 200 && sc < 300 + Just good -> sc `elem` (statusCode <$> good) + if goodStatus then k (Right res'') else k (Left (mkFailureResponse burl req res'')) diff --git a/servant-http-streams/test/Servant/ClientSpec.hs b/servant-http-streams/test/Servant/ClientSpec.hs index 4ea340b9..3545492f 100644 --- a/servant-http-streams/test/Servant/ClientSpec.hs +++ b/servant-http-streams/test/Servant/ClientSpec.hs @@ -44,8 +44,6 @@ import Data.Maybe (isJust) import Data.Monoid () import Data.Proxy -import Data.Semigroup - ((<>)) import GHC.Generics (Generic) import qualified Network.HTTP.Types as HTTP @@ -78,7 +76,7 @@ _ = client comprehensiveAPIWithoutStreaming spec :: Spec spec = describe "Servant.HttpStreams" $ do - sucessSpec + successSpec failSpec wrappedApiSpec basicAuthSpec @@ -270,8 +268,8 @@ runClientUnsafe x burl = withClientEnvIO burl (runClientMUnsafe x) where runClientMUnsafe x env = withClientM x env return -sucessSpec :: Spec -sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do +successSpec :: Spec +successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Servant.API.Get root" $ \(_, baseUrl) -> do left show <$> runClient getRoot baseUrl `shouldReturn` Right carol @@ -495,7 +493,7 @@ startWaiApp app = do (port, socket) <- openTestSocket let settings = setPort port $ defaultSettings thread <- forkIO $ runSettingsSocket settings socket app - return (thread, BaseUrl Http "localhost" port "") + return (thread, BaseUrl Http "127.0.0.1" port "") endWaiApp :: (ThreadId, BaseUrl) -> IO () diff --git a/servant-machines/servant-machines.cabal b/servant-machines/servant-machines.cabal index 31f1de7d..cdf55fdf 100644 --- a/servant-machines/servant-machines.cabal +++ b/servant-machines/servant-machines.cabal @@ -1,7 +1,6 @@ cabal-version: >=1.10 name: servant-machines -version: 0.15 -x-revision: 1 +version: 0.15.1 synopsis: Servant Stream support for machines category: Servant, Web, Enumerator @@ -11,18 +10,13 @@ description: Servant Stream support for machines. homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2018-2019 Servant Contributors build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 extra-source-files: CHANGELOG.md @@ -35,10 +29,10 @@ library exposed-modules: Servant.Machines build-depends: base >=4.9 && <5 - , bytestring >=0.10.8.1 && <0.11 + , bytestring >=0.10.8.1 && <0.12 , machines >=0.6.4 && <0.8 , mtl >=2.2.2 && <2.3 - , servant >=0.15 && <0.17 + , servant >=0.15 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -57,8 +51,8 @@ test-suite example , servant , machines , servant-machines - , servant-server >=0.15 && <0.17 - , servant-client >=0.15 && <0.17 + , servant-server >=0.15 && <0.19 + , servant-client >=0.15 && <0.19 , wai >=3.2.1.2 && <3.3 , warp >=3.2.25 && <3.4 , http-client diff --git a/servant-pipes/CHANGELOG.md b/servant-pipes/CHANGELOG.md index 113b5c4b..248b5eaf 100644 --- a/servant-pipes/CHANGELOG.md +++ b/servant-pipes/CHANGELOG.md @@ -1,3 +1,14 @@ +0.15.3 +------ + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring` dependency. + +0.15.2 +------ + 0.15.1 ------ diff --git a/servant-pipes/example/Main.hs b/servant-pipes/example/Main.hs index 157ac2e7..8683f651 100644 --- a/servant-pipes/example/Main.hs +++ b/servant-pipes/example/Main.hs @@ -64,7 +64,7 @@ server = fast :<|> slow :<|> readme :<|> proxy readme = liftIO $ do putStrLn "/readme" - return $ P.withFile "README.md" ReadMode PBS.fromHandle + return $ P.withFile "README.md" ReadMode $ \h -> PBS.fromHandle h proxy c = liftIO $ do putStrLn "/proxy" diff --git a/servant-pipes/servant-pipes.cabal b/servant-pipes/servant-pipes.cabal index 5fdc4b5a..4ed0ff02 100644 --- a/servant-pipes/servant-pipes.cabal +++ b/servant-pipes/servant-pipes.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-pipes -version: 0.15.1 +version: 0.15.3 synopsis: Servant Stream support for pipes category: Servant, Web, Pipes @@ -10,18 +10,13 @@ description: Servant Stream support for pipes. homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2018-2019 Servant Contributors build-type: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 extra-source-files: CHANGELOG.md @@ -34,12 +29,12 @@ library exposed-modules: Servant.Pipes build-depends: base >=4.9 && <5 - , bytestring >=0.10.8.1 && <0.11 + , bytestring >=0.10.8.1 && <0.12 , pipes >=4.3.9 && <4.4 , pipes-safe >=2.3.1 && <2.4 , mtl >=2.2.2 && <2.3 , monad-control >=1.0.2.3 && <1.1 - , servant >=0.15 && <0.17 + , servant >=0.15 && <0.19 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -60,8 +55,8 @@ test-suite example , pipes-safe , servant-pipes , pipes-bytestring >=2.1.6 && <2.2 - , servant-server >=0.15 && <0.17 - , servant-client >=0.15 && <0.17 + , servant-server >=0.15 && <0.19 + , servant-client >=0.15 && <0.19 , wai >=3.2.1.2 && <3.3 , warp >=3.2.25 && <3.4 , http-client diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 22098411..b33d9877 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,6 +1,93 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/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.18.3 +------ + +### Significant changes + +- Add response header support to UVerb (#1420) + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring`, `hspec` and `base64-bytestring` dependencies. + +0.18.2 +------ + +### Significant changes + +- Support `Fragment` combinator. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions +- Allow newer dependencies + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + +- Configurable error messages for automatic errors thrown by servant, + like "no route" or "could not parse json body" (#1312, #1326, #1327) + + +0.17 +---- + +### Significant changes + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + 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. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + 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. + +- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262) + + 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 modifying + request's `Query`. But QueryParam, QueryParams and QueryFlag use + `rawQueryString`. By using `queryString` rather then `rawQueryString` + we can enable such rewritings. + +- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263) + + 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 conveniently). + 0.16.2 ------ diff --git a/servant-server/example/README.md b/servant-server/example/README.md index a787d7c7..a50ff4cb 100644 --- a/servant-server/example/README.md +++ b/servant-server/example/README.md @@ -1,2 +1,2 @@ - `greet.hs` shows how to write a simple webservice, run it, query it with automatically-derived haskell functions and print the (generated) markdown documentation for the API. -- `greet.md` contains the aforementionned generated documentation. \ No newline at end of file +- `greet.md` contains the aforementioned generated documentation. \ No newline at end of file diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 27defcae..ba564b1a 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-server -version: 0.16 +version: 0.18.3 synopsis: A family of combinators for defining webservices APIs and serving them category: Servant, Web @@ -17,18 +17,13 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause 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: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 extra-source-files: CHANGELOG.md @@ -49,12 +44,14 @@ library Servant.Server.Internal.Context Servant.Server.Internal.Delayed Servant.Server.Internal.DelayedIO + Servant.Server.Internal.ErrorFormatter Servant.Server.Internal.Handler - Servant.Server.Internal.Router Servant.Server.Internal.RouteResult + Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication Servant.Server.Internal.ServerError Servant.Server.StaticFiles + Servant.Server.UVerb -- deprecated exposed-modules: @@ -63,8 +60,8 @@ library -- 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.14 - , bytestring >= 0.10.8.1 && < 0.11 + base >= 4.9 && < 4.16 + , bytestring >= 0.10.8.1 && < 0.12 , containers >= 0.5.7.1 && < 0.7 , mtl >= 2.2.2 && < 2.3 , text >= 1.2.3.0 && < 1.3 @@ -74,20 +71,21 @@ library -- Servant dependencies -- strict dependency as we re-export 'servant' things. build-depends: - servant >= 0.16 && < 0.17.1 - , http-api-data >= 0.4.1 && < 0.4.2 + servant >= 0.18.3 && < 0.18.4 + , http-api-data >= 0.4.1 && < 0.4.4 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.12 - , base64-bytestring >= 1.0.0.1 && < 1.1 + , base64-bytestring >= 1.0.0.1 && < 1.3 , exceptions >= 0.10.0 && < 0.11 , http-media >= 0.7.1.3 && < 0.9 , http-types >= 0.12.2 && < 0.13 , network-uri >= 2.6.1.0 && < 2.8 , monad-control >= 1.0.2.3 && < 1.1 , network >= 2.8 && < 3.2 + , sop-core >= 0.4.0.0 && < 0.6 , string-conversions >= 0.4.0.1 && < 0.5 , resourcet >= 1.2.2 && < 1.3 , tagged >= 0.8.6 && < 0.9 @@ -98,6 +96,7 @@ library hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall -Wno-redundant-constraints executable greet @@ -114,7 +113,7 @@ executable greet , text build-depends: - aeson >= 1.4.1.0 && < 1.5 + aeson >= 1.4.1.0 && < 1.6 , warp >= 3.2.25 && < 3.4 test-suite spec @@ -149,22 +148,23 @@ test-suite spec , safe , servant , servant-server + , sop-core , string-conversions , text , transformers , transformers-compat , wai - -- Additonal dependencies + -- Additional dependencies build-depends: - aeson >= 1.4.1.0 && < 1.5 + aeson >= 1.4.1.0 && < 1.6 , directory >= 1.3.0.0 && < 1.4 - , hspec >= 2.6.0 && < 2.8 - , hspec-wai >= 0.10.1 && < 0.11 - , QuickCheck >= 2.12.6.1 && < 2.14 + , hspec >= 2.6.0 && < 2.9 + , hspec-wai >= 0.10.1 && < 0.12 + , QuickCheck >= 2.12.6.1 && < 2.15 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4 - , wai-extra >= 3.0.24.3 && < 3.1 + , wai-extra >= 3.0.24.3 && < 3.2 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && <2.8 + hspec-discover:hspec-discover >= 2.6.0 && <2.9 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index e2d9f3c5..fa01daeb 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | This module lets you implement 'Server's for defined APIs. You'll -- most likely just need 'serve'. @@ -10,6 +12,8 @@ module Servant.Server ( -- * Run a wai application from an API serve , serveWithContext + , serveWithContextT + , ServerContext , -- * Construct a wai Application from an API toApplication @@ -35,6 +39,8 @@ module Servant.Server -- * Context , Context(..) , HasContextEntry(getContextEntry) + , type (.++) + , (.++) -- ** NamedContext , NamedContext(..) , descendIntoNamedContext @@ -86,9 +92,28 @@ module Servant.Server , err504 , err505 + -- * Formatting of errors from combinators + -- + -- | You can configure how Servant will render errors that occur while parsing the request. + + , ErrorFormatter + , NotFoundErrorFormatter + , ErrorFormatters + + , bodyParserErrorFormatter + , urlParseErrorFormatter + , headerParseErrorFormatter + , notFoundErrorFormatter + + , DefaultErrorFormatters + , defaultErrorFormatters + + , getAcceptHeader + -- * Re-exports , Application , Tagged (..) + , module Servant.Server.UVerb ) where @@ -101,10 +126,20 @@ import Data.Text import Network.Wai (Application) import Servant.Server.Internal +import Servant.Server.UVerb -- * Implementing Servers +-- | Constraints that need to be satisfied on a context for it to be passed to 'serveWithContext'. +-- +-- Typically, this will add default context entries to the context. You shouldn't typically +-- need to worry about these constraints, but if you write a helper function that wraps +-- 'serveWithContext', you might need to include this constraint. +type ServerContext context = + ( HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters + ) + -- | 'serve' allows you to implement an API and produce a wai 'Application'. -- -- Example: @@ -129,10 +164,27 @@ import Servant.Server.Internal serve :: (HasServer api '[]) => Proxy api -> Server api -> Application serve p = serveWithContext p EmptyContext -serveWithContext :: (HasServer api context) +-- | Like 'serve', but allows you to pass custom context. +-- +-- 'defaultErrorFormatters' will always be appended to the end of the passed context, +-- but if you pass your own formatter, it will override the default one. +serveWithContext :: ( HasServer api context + , ServerContext context + ) => Proxy api -> Context context -> Server api -> Application -serveWithContext p context server = - toApplication (runRouter (route p context (emptyDelayed (Route server)))) +serveWithContext p context = serveWithContextT p context id + +-- | A general 'serve' function that allows you to pass a custom context and hoisting function to +-- apply on all routes. +serveWithContextT :: + forall api context m. + (HasServer api context, ServerContext context) => + Proxy api -> Context context -> (forall x. m x -> Handler x) -> ServerT api m -> Application +serveWithContextT p context toHandler server = + toApplication (runRouter format404 (route p context (emptyDelayed router))) + where + router = Route $ hoistServerWithContext p (Proxy :: Proxy context) toHandler server + format404 = notFoundErrorFormatter . getContextEntry . mkContextWithErrorFormatter $ context -- | Hoist server implementation. -- diff --git a/servant-server/src/Servant/Server/Generic.hs b/servant-server/src/Servant/Server/Generic.hs index c3a2e3b4..c3db01c3 100644 --- a/servant-server/src/Servant/Server/Generic.hs +++ b/servant-server/src/Servant/Server/Generic.hs @@ -31,7 +31,7 @@ instance GenericMode (AsServerT m) where type AsServer = AsServerT Handler --- | Transform record of routes into a WAI 'Application'. +-- | Transform a record of routes into a WAI 'Application'. genericServe :: forall routes. ( HasServer (ToServantApi routes) '[] @@ -67,6 +67,7 @@ genericServeTWithContext ( GenericServant routes (AsServerT m) , GenericServant routes AsApi , HasServer (ToServantApi routes) ctx + , HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters , ServerT (ToServantApi routes) m ~ ToServant routes (AsServerT m) ) => (forall a. m a -> Handler a) -- ^ 'hoistServer' argument to come back to 'Handler' @@ -80,13 +81,17 @@ genericServeTWithContext f server ctx = p = genericApi (Proxy :: Proxy routes) pctx = Proxy :: Proxy ctx --- | Transform record of endpoints into a 'Server'. +-- | Transform a record of endpoints into a 'Server'. genericServer :: GenericServant routes AsServer => routes AsServer -> ToServant routes AsServer genericServer = toServant +-- | Transform a record of endpoints into a @'ServerT' m@. +-- +-- You can see an example usage of this function +-- . genericServerT :: GenericServant routes (AsServerT m) => routes (AsServerT m) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 36f9f15e..4331c1a1 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -24,6 +24,7 @@ module Servant.Server.Internal , module Servant.Server.Internal.Context , module Servant.Server.Internal.Delayed , module Servant.Server.Internal.DelayedIO + , module Servant.Server.Internal.ErrorFormatter , module Servant.Server.Internal.Handler , module Servant.Server.Internal.Router , module Servant.Server.Internal.RouteResult @@ -45,8 +46,6 @@ import Data.Either (partitionEithers) import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList) -import Data.Semigroup - ((<>)) import Data.String (IsString (..)) import Data.String.Conversions @@ -64,23 +63,23 @@ import Network.Socket (SockAddr) import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody, - queryString, rawQueryString, remoteHost, requestBody, requestHeaders, + queryString, rawQueryString, remoteHost, getRequestBodyChunk, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude () import Prelude.Compat import Servant.API ((:<|>) (..), (:>), Accept (..), BasicAuth, Capture', - CaptureAll, Description, EmptyAPI, FramingRender (..), - FramingUnrender (..), FromSourceIO (..), Header', If, - IsSecure (..), QueryFlag, QueryParam', QueryParamForm', QueryParams, Raw, - ReflectMethod (reflectMethod), RemoteHost, ReqBody', - SBool (..), SBoolI (..), SourceIO, Stream, StreamBody', - Summary, ToSourceIO (..), Vault, Verb, NoContentVerb, + CaptureAll, Description, EmptyAPI, Fragment, + FramingRender (..), FramingUnrender (..), FromSourceIO (..), + Header', If, IsSecure (..), NoContentVerb, QueryFlag, + QueryParam', QueryParams, QueryParamForm', Raw, ReflectMethod (reflectMethod), + RemoteHost, ReqBody', SBool (..), SBoolI (..), SourceIO, + Stream, StreamBody', Summary, ToSourceIO (..), Vault, Verb, WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), - AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH, - NoContent) + AllMime, MimeRender (..), MimeUnrender (..), NoContent, + canHandleAcceptH) import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument) @@ -90,13 +89,14 @@ import Web.FormUrlEncoded (FromForm(..), urlDecodeAsForm) import qualified Servant.Types.SourceT as S import Web.HttpApiData - (FromHttpApiData, parseHeader, parseQueryParam, - parseUrlPieces, parseUrlPiece) + (FromHttpApiData, parseHeader, parseQueryParam, parseUrlPiece, + parseUrlPieces) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context import Servant.Server.Internal.Delayed import Servant.Server.Internal.DelayedIO +import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.Handler import Servant.Server.Internal.Router import Servant.Server.Internal.RouteResult @@ -106,6 +106,8 @@ import Servant.Server.Internal.ServerError #ifdef HAS_TYPE_ERROR import GHC.TypeLits (ErrorMessage (..), TypeError) +import Servant.API.TypeLevel + (AtLeastOneFragment, FragmentUnique) #endif class HasServer api context where @@ -170,7 +172,10 @@ instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) cont -- > server = getBook -- > where getBook :: Text -> Handler Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI (FoldLenient mods)) +instance (KnownSymbol capture, FromHttpApiData a + , HasServer api context, SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => HasServer (Capture' mods capture a :> api) context where type ServerT (Capture' mods capture a :> api) m = @@ -182,12 +187,15 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI CaptureRouter $ route (Proxy :: Proxy api) context - (addCapture d $ \ txt -> case ( sbool :: SBool (FoldLenient mods) - , parseUrlPiece txt :: Either T.Text a) of - (SFalse, Left e) -> delayedFail err400 { errBody = cs e } - (SFalse, Right v) -> return v - (STrue, piece) -> return $ (either (Left . cs) Right) piece - ) + (addCapture d $ \ txt -> withRequest $ \ request -> + case ( sbool :: SBool (FoldLenient mods) + , parseUrlPiece txt :: Either T.Text a) of + (SFalse, Left e) -> delayedFail $ formatError rep request $ cs e + (SFalse, Right v) -> return v + (STrue, piece) -> return $ (either (Left . cs) Right) piece) + where + rep = typeRep (Proxy :: Proxy Capture') + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) -- | If you use 'CaptureAll' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a @@ -206,7 +214,10 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context, SBoolI -- > server = getSourceFile -- > where getSourceFile :: [Text] -> Handler Book -- > getSourceFile pathSegments = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) +instance (KnownSymbol capture, FromHttpApiData a + , HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters + ) => HasServer (CaptureAll capture a :> api) context where type ServerT (CaptureAll capture a :> api) m = @@ -218,11 +229,14 @@ instance (KnownSymbol capture, FromHttpApiData a, HasServer api context) CaptureAllRouter $ route (Proxy :: Proxy api) context - (addCapture d $ \ txts -> case parseUrlPieces txts of - Left _ -> delayedFail err400 - Right v -> return v + (addCapture d $ \ txts -> withRequest $ \ request -> + case parseUrlPieces txts of + Left e -> delayedFail $ formatError rep request $ cs e + Right v -> return v ) - + where + rep = typeRep (Proxy :: Proxy CaptureAll) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -242,10 +256,10 @@ methodCheck method request -- body check is no longer an option. However, we now run the accept -- check before the body check and can therefore afford to make it -- recoverable. -acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> DelayedIO () +acceptCheck :: (AllMime list) => Proxy list -> AcceptHeader -> DelayedIO () acceptCheck proxy accH - | canHandleAcceptH proxy (AcceptHeader accH) = return () - | otherwise = delayedFail err406 + | canHandleAcceptH proxy accH = return () + | otherwise = delayedFail err406 methodRouter :: (AllCTRender ctypes a) => (b -> ([(HeaderName, B.ByteString)], a)) @@ -255,12 +269,12 @@ methodRouter :: (AllCTRender ctypes a) methodRouter splitHeaders method proxy status action = leafRouter route' where route' env request respond = - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + let accH = getAcceptHeader request in runAction (action `addMethodCheck` methodCheck method request `addAcceptCheck` acceptCheck proxy accH ) env request respond $ \ output -> do let (headers, b) = splitHeaders output - case handleAcceptH proxy (AcceptHeader accH) b of + case handleAcceptH proxy accH b of Nothing -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does Just (contentT, body) -> let bdy = if allowedMethodHead method request then "" else body @@ -345,7 +359,7 @@ streamRouter :: forall ctype a c chunk env framing. (MimeRender ctype chunk, Fra -> Delayed env (Handler c) -> Router env streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> - let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request + let AcceptHeader accH = getAcceptHeader request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 contentHeader = (hContentType, NHM.renderHeader . maybeToList $ cmediatype) @@ -390,6 +404,7 @@ streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRou instance (KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (Header' mods sym a :> api) context where ------ @@ -401,6 +416,9 @@ instance route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addHeaderCheck` withRequest headerCheck where + rep = typeRep (Proxy :: Proxy Header') + formatError = headerParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + headerName :: IsString n => n headerName = fromString $ symbolVal (Proxy :: Proxy sym) @@ -411,15 +429,13 @@ instance mev :: Maybe (Either T.Text a) mev = fmap parseHeader $ lookup headerName (requestHeaders req) - errReq = delayedFailFatal err400 - { errBody = "Header " <> headerName <> " is required" - } + errReq = delayedFailFatal $ formatError rep req + $ "Header " <> headerName <> " is required" - errSt e = delayedFailFatal err400 - { errBody = cs $ "Error parsing header " - <> headerName - <> " failed: " <> e - } + errSt e = delayedFailFatal $ formatError rep req + $ cs $ "Error parsing header " + <> headerName + <> " failed: " <> e -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -445,6 +461,7 @@ instance instance ( KnownSymbol sym, FromHttpApiData a, HasServer api context , SBoolI (FoldRequired mods), SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (QueryParam' mods sym a :> api) context where ------ @@ -457,6 +474,9 @@ instance let querytext = queryToQueryText . queryString paramname = cs $ symbolVal (Proxy :: Proxy sym) + rep = typeRep (Proxy :: Proxy QueryParam') + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + parseParam :: Request -> DelayedIO (RequestArgument mods a) parseParam req = unfoldRequestArgument (Proxy :: Proxy mods) errReq errSt mev @@ -464,14 +484,12 @@ instance mev :: Maybe (Either T.Text a) mev = fmap parseQueryParam $ join $ lookup paramname $ querytext req - errReq = delayedFailFatal err400 - { errBody = cs $ "Query parameter " <> paramname <> " is required" - } + errReq = delayedFailFatal $ formatError rep req + $ cs $ "Query parameter " <> paramname <> " is required" - errSt e = delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter " - <> paramname <> " failed: " <> e - } + errSt e = delayedFailFatal $ formatError rep req + $ cs $ "Error parsing query parameter " + <> paramname <> " failed: " <> e delayed = addParameterCheck subserver . withRequest $ \req -> parseParam req @@ -497,7 +515,8 @@ instance -- > server = getBooksBy -- > where getBooksBy :: [Text] -> Handler [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) +instance (KnownSymbol sym, FromHttpApiData a, HasServer api context + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters) => HasServer (QueryParams sym a :> api) context where type ServerT (QueryParams sym a :> api) m = @@ -508,15 +527,17 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) route Proxy context subserver = route (Proxy :: Proxy api) context $ subserver `addParameterCheck` withRequest paramsCheck where + rep = typeRep (Proxy :: Proxy QueryParams) + formatError = urlParseErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + paramname = cs $ symbolVal (Proxy :: Proxy sym) paramsCheck req = case partitionEithers $ fmap parseQueryParam params of ([], parsed) -> return parsed - (errs, _) -> delayedFailFatal err400 - { errBody = cs $ "Error parsing query parameter(s) " - <> paramname <> " failed: " - <> T.intercalate ", " errs - } + (errs, _) -> delayedFailFatal $ formatError rep req + $ cs $ "Error parsing query parameter(s) " + <> paramname <> " failed: " + <> T.intercalate ", " errs where params :: [T.Text] params = mapMaybe snd @@ -654,7 +675,7 @@ instance HasServer Raw context where -- The @Content-Type@ header is inspected, and the list provided is used to -- attempt deserialization. If the request does not have a @Content-Type@ -- header, it is treated as @application/octet-stream@ (as specified in --- . +-- [RFC 7231 section 3.1.1.5](http://tools.ietf.org/html/rfc7231#section-3.1.1.5)). -- This lets servant worry about extracting it from the request and turning -- it into a value of the type you specify. -- @@ -670,6 +691,7 @@ instance HasServer Raw context where -- > where postBook :: Book -> Handler Book -- > postBook book = ...insert into your db... instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods) + , HasContextEntry (MkContextWithErrorFormatter context) ErrorFormatters ) => HasServer (ReqBody' mods list a :> api) context where type ServerT (ReqBody' mods list a :> api) m = @@ -681,6 +703,9 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods = route (Proxy :: Proxy api) context $ addBodyCheck subserver ctCheck bodyCheck where + rep = typeRep (Proxy :: Proxy ReqBody') + formatError = bodyParserErrorFormatter $ getContextEntry (mkContextWithErrorFormatter context) + -- Content-Type check, we only lookup we can try to parse the request body ctCheck = withRequest $ \ request -> do -- See HTTP RFC 2616, section 7.2.1 @@ -699,7 +724,7 @@ instance ( AllCTUnrender list a, HasServer api context, SBoolI (FoldLenient mods case sbool :: SBool (FoldLenient mods) of STrue -> return mrqbody SFalse -> case mrqbody of - Left e -> delayedFailFatal err400 { errBody = cs e } + Left e -> delayedFailFatal $ formatError rep request e Right v -> return v instance @@ -722,7 +747,7 @@ instance bodyCheck fromRS = withRequest $ \req -> do let mimeUnrender' = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString -> SourceIO chunk - let body = requestBody req + let body = getRequestBodyChunk req let rs = S.fromAction B.null body let rs' = fromRS $ framingUnrender' rs return rs' @@ -791,12 +816,12 @@ data EmptyServer = EmptyServer deriving (Typeable, Eq, Show, Bounded, Enum) emptyServer :: ServerT EmptyAPI m emptyServer = Tagged EmptyServer --- | The server for an `EmptyAPI` is `emptyAPIServer`. +-- | The server for an `EmptyAPI` is `emptyServer`. -- -- > type MyApi = "nothing" :> EmptyApi -- > -- > server :: Server MyApi --- > server = emptyAPIServer +-- > server = emptyServer instance HasServer EmptyAPI context where type ServerT EmptyAPI m = Tagged m EmptyServer @@ -827,6 +852,9 @@ instance ( KnownSymbol realm ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP +getAcceptHeader :: Request -> AcceptHeader +getAcceptHeader = AcceptHeader . fromMaybe ct_wildcard . lookup hAccept . requestHeaders + -- * General Authentication @@ -874,7 +902,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context where type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr) - -- it doens't really matter what sub route we peak + -- it doesn't really matter what sub route we peak route _ _ _ = error "servant-server panic: impossible happened in HasServer (arr :> api)" hoistServerWithContext _ _ _ = id @@ -918,5 +946,28 @@ type HasServerArrowTypeError a b = ':$$: 'ShowType b #endif +-- | Ignore @'Fragment'@ in server handlers. +-- See for more details. +-- +-- Example: +-- +-- > type MyApi = "books" :> Fragment Text :> Get '[JSON] [Book] +-- > +-- > server :: Server MyApi +-- > server = getBooks +-- > where getBooks :: Handler [Book] +-- > getBooks = ...return all books... +#ifdef HAS_TYPE_ERROR +instance (AtLeastOneFragment api, FragmentUnique (Fragment a1 :> api), HasServer api context) +#else +instance (HasServer api context) +#endif + => HasServer (Fragment a1 :> api) context where + type ServerT (Fragment a1 :> api) m = ServerT api m + + route _ = route (Proxy :: Proxy api) + + hoistServerWithContext _ = hoistServerWithContext (Proxy :: Proxy api) + -- $setup -- >>> import Servant diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs index 8b5e06ae..4b30d897 100644 --- a/servant-server/src/Servant/Server/Internal/BasicAuth.hs +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -12,8 +12,6 @@ import Control.Monad.Trans import qualified Data.ByteString as BS import Data.ByteString.Base64 (decodeLenient) -import Data.Monoid - ((<>)) import Data.Typeable (Typeable) import Data.Word8 @@ -32,7 +30,7 @@ import Servant.Server.Internal.ServerError -- * Basic Auth -- | servant-server's current implementation of basic authentication is not --- immune to certian kinds of timing attacks. Decoding payloads does not take +-- immune to certain kinds of timing attacks. Decoding payloads does not take -- a fixed amount of time. -- | The result of authentication/authorization diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs index 45a72761..cb4c23be 100644 --- a/servant-server/src/Servant/Server/Internal/Context.hs +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Servant.Server.Internal.Context where @@ -20,7 +21,7 @@ import GHC.TypeLits -- -- If you are using combinators that require a non-empty 'Context' you have to -- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all --- the values your combinators need. A 'Context' is essentially a heterogenous +-- the values your combinators need. A 'Context' is essentially a heterogeneous -- list and accessing the elements is being done by type (see 'getContextEntry'). -- The parameter of the type 'Context' is a type-level list reflecting the types -- of the contained context entries. To create a 'Context' with entries, use the @@ -45,6 +46,20 @@ instance Eq (Context '[]) where instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 +-- | Append two type-level lists. +-- +-- Hint: import it as +-- +-- > import Servant.Server (type (.++)) +type family (.++) (l1 :: [*]) (l2 :: [*]) where + '[] .++ a = a + (a ': as) .++ b = a ': (as .++ b) + +-- | Append two contexts. +(.++) :: Context l1 -> Context l2 -> Context (l1 .++ l2) +EmptyContext .++ a = a +(a :. as) .++ b = a :. (as .++ b) + -- | This class is used to access context entries in 'Context's. 'getContextEntry' -- returns the first value where the type matches: -- diff --git a/servant-server/src/Servant/Server/Internal/Delayed.hs b/servant-server/src/Servant/Server/Internal/Delayed.hs index 1e580cf6..3ba89574 100644 --- a/servant-server/src/Servant/Server/Internal/Delayed.hs +++ b/servant-server/src/Servant/Server/Internal/Delayed.hs @@ -268,5 +268,5 @@ runAction action env req respond k = runResourceT $ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Due to GHC issue , we cannot -do the more succint thing - just update the records we actually change. +do the more succinct thing - just update the records we actually change. -} diff --git a/servant-server/src/Servant/Server/Internal/DelayedIO.hs b/servant-server/src/Servant/Server/Internal/DelayedIO.hs index 48f35b9d..6aaa23ae 100644 --- a/servant-server/src/Servant/Server/Internal/DelayedIO.hs +++ b/servant-server/src/Servant/Server/Internal/DelayedIO.hs @@ -24,7 +24,7 @@ import Servant.Server.Internal.ServerError -- | Computations used in a 'Delayed' can depend on the -- incoming 'Request', may perform 'IO', and result in a --- 'RouteResult', meaning they can either suceed, fail +-- 'RouteResult', meaning they can either succeed, fail -- (with the possibility to recover), or fail fatally. -- newtype DelayedIO a = DelayedIO { runDelayedIO' :: ReaderT Request (ResourceT (RouteResultT IO)) a } diff --git a/servant-server/src/Servant/Server/Internal/ErrorFormatter.hs b/servant-server/src/Servant/Server/Internal/ErrorFormatter.hs new file mode 100644 index 00000000..26a7e85b --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/ErrorFormatter.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.Internal.ErrorFormatter + ( ErrorFormatters(..) + , ErrorFormatter + , NotFoundErrorFormatter + + , DefaultErrorFormatters + , defaultErrorFormatters + + , MkContextWithErrorFormatter + , mkContextWithErrorFormatter + ) where + +import Data.String.Conversions + (cs) +import Data.Typeable +import Network.Wai.Internal + (Request) + +import Servant.API + (Capture, ReqBody) +import Servant.Server.Internal.Context +import Servant.Server.Internal.ServerError + +-- | 'Context' that contains default error formatters. +type DefaultErrorFormatters = '[ErrorFormatters] + +-- | A collection of error formatters for different situations. +-- +-- If you need to override one of them, use 'defaultErrorFormatters' with record update syntax. +data ErrorFormatters = ErrorFormatters + { -- | Format error from parsing the request body. + bodyParserErrorFormatter :: ErrorFormatter + -- | Format error from parsing url parts or query parameters. + , urlParseErrorFormatter :: ErrorFormatter + -- | Format error from parsing request headers. + , headerParseErrorFormatter :: ErrorFormatter + -- | Format error for not found URLs. + , notFoundErrorFormatter :: NotFoundErrorFormatter + } + +-- | Default formatters will just return HTTP 400 status code with error +-- message as response body. +defaultErrorFormatters :: ErrorFormatters +defaultErrorFormatters = ErrorFormatters + { bodyParserErrorFormatter = err400Formatter + , urlParseErrorFormatter = err400Formatter + , headerParseErrorFormatter = err400Formatter + , notFoundErrorFormatter = const err404 + } + +-- | A custom formatter for errors produced by parsing combinators like +-- 'ReqBody' or 'Capture'. +-- +-- A 'TypeRep' argument described the concrete combinator that raised +-- the error, allowing formatter to customize the message for different +-- combinators. +-- +-- A full 'Request' is also passed so that the formatter can react to @Accept@ header, +-- for example. +type ErrorFormatter = TypeRep -> Request -> String -> ServerError + +-- | This formatter does not get neither 'TypeRep' nor error message. +type NotFoundErrorFormatter = Request -> ServerError + +type MkContextWithErrorFormatter (ctx :: [*]) = ctx .++ DefaultErrorFormatters + +mkContextWithErrorFormatter :: forall (ctx :: [*]). Context ctx -> Context (MkContextWithErrorFormatter ctx) +mkContextWithErrorFormatter ctx = ctx .++ (defaultErrorFormatters :. EmptyContext) + +-- Internal + +err400Formatter :: ErrorFormatter +err400Formatter _ _ e = err400 { errBody = cs e } + +-- These definitions suppress "unused import" warning. +-- The imorts are needed for Haddock to correctly link to them. +_RB :: Proxy ReqBody +_RB = Proxy +_C :: Proxy Capture +_C = Proxy +_CT :: Proxy Context +_CT = Proxy diff --git a/servant-server/src/Servant/Server/Internal/Router.hs b/servant-server/src/Servant/Server/Internal/Router.hs index d6735c9e..ecee5901 100644 --- a/servant-server/src/Servant/Server/Internal/Router.hs +++ b/servant-server/src/Servant/Server/Internal/Router.hs @@ -17,8 +17,9 @@ import Data.Text import qualified Data.Text as T import Network.Wai (Response, pathInfo) -import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.ErrorFormatter import Servant.Server.Internal.RouteResult +import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServerError type Router env = Router' env RoutingApplication @@ -153,52 +154,52 @@ tweakResponse :: (RouteResult Response -> RouteResult Response) -> Router env -> tweakResponse f = fmap (\a -> \req cont -> a req (cont . f)) -- | Interpret a router as an application. -runRouter :: Router () -> RoutingApplication -runRouter r = runRouterEnv r () +runRouter :: NotFoundErrorFormatter -> Router () -> RoutingApplication +runRouter fmt r = runRouterEnv fmt r () -runRouterEnv :: Router env -> env -> RoutingApplication -runRouterEnv router env request respond = +runRouterEnv :: NotFoundErrorFormatter -> Router env -> env -> RoutingApplication +runRouterEnv fmt router env request respond = case router of StaticRouter table ls -> case pathInfo request of - [] -> runChoice ls env request respond + [] -> runChoice fmt ls env request respond -- This case is to handle trailing slashes. - [""] -> runChoice ls env request respond + [""] -> runChoice fmt ls env request respond first : rest | Just router' <- M.lookup first table -> let request' = request { pathInfo = rest } - in runRouterEnv router' env request' respond - _ -> respond $ Fail err404 + in runRouterEnv fmt router' env request' respond + _ -> respond $ Fail $ fmt request CaptureRouter router' -> case pathInfo request of - [] -> respond $ Fail err404 + [] -> respond $ Fail $ fmt request -- This case is to handle trailing slashes. - [""] -> respond $ Fail err404 + [""] -> respond $ Fail $ fmt request first : rest -> let request' = request { pathInfo = rest } - in runRouterEnv router' (first, env) request' respond + in runRouterEnv fmt router' (first, env) request' respond CaptureAllRouter router' -> let segments = pathInfo request request' = request { pathInfo = [] } - in runRouterEnv router' (segments, env) request' respond + in runRouterEnv fmt router' (segments, env) request' respond RawRouter app -> app env request respond Choice r1 r2 -> - runChoice [runRouterEnv r1, runRouterEnv r2] env request respond + runChoice fmt [runRouterEnv fmt r1, runRouterEnv fmt r2] env request respond -- | Try a list of routing applications in order. -- We stop as soon as one fails fatally or succeeds. -- If all fail normally, we pick the "best" error. -- -runChoice :: [env -> RoutingApplication] -> env -> RoutingApplication -runChoice ls = +runChoice :: NotFoundErrorFormatter -> [env -> RoutingApplication] -> env -> RoutingApplication +runChoice fmt ls = case ls of - [] -> \ _ _ respond -> respond (Fail err404) + [] -> \ _ request respond -> respond (Fail $ fmt request) [r] -> r (r : rs) -> \ env request respond -> r env request $ \ response1 -> case response1 of - Fail _ -> runChoice rs env request $ \ response2 -> + Fail _ -> runChoice fmt rs env request $ \ response2 -> respond $ highestPri response1 response2 _ -> respond response1 where diff --git a/servant-server/src/Servant/Server/Internal/ServerError.hs b/servant-server/src/Servant/Server/Internal/ServerError.hs index a22e953b..5b5d56e2 100644 --- a/servant-server/src/Servant/Server/Internal/ServerError.hs +++ b/servant-server/src/Servant/Server/Internal/ServerError.hs @@ -187,7 +187,7 @@ err403 = ServerError { errHTTPCode = 403 -- Example: -- -- > failingHandler :: Handler () --- > failingHandler = throwError $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } +-- > failingHandler = throwError $ err404 { errBody = "Are you lost?" } -- err404 :: ServerError err404 = ServerError { errHTTPCode = 404 diff --git a/servant-server/src/Servant/Server/UVerb.hs b/servant-server/src/Servant/Server/UVerb.hs new file mode 100644 index 00000000..4b934d91 --- /dev/null +++ b/servant-server/src/Servant/Server/UVerb.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Servant.Server.UVerb + ( respond, + IsServerResource, + ) +where + +import qualified Data.ByteString as B +import Data.Proxy (Proxy (Proxy)) +import Data.SOP (I (I)) +import Data.SOP.Constraint (All, And) +import Data.String.Conversions (LBS, cs) +import Network.HTTP.Types (Status, HeaderName, hContentType) +import Network.Wai (responseLBS, Request) +import Servant.API (ReflectMethod, reflectMethod) +import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime) +import Servant.API.ResponseHeaders (GetHeaders (..), Headers (..)) +import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, WithStatus (..), foldMapUnion, inject, statusOf) +import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction) + + +-- | 'return' for 'UVerb' handlers. Takes a value of any of the members of the open union, +-- and will construct a union value in an 'Applicative' (eg. 'Server'). +respond :: + forall (x :: *) (xs :: [*]) (f :: * -> *). + (Applicative f, HasStatus x, IsMember x xs) => + x -> + f (Union xs) +respond = pure . inject . I + +class IsServerResource (cts :: [*]) a where + resourceResponse :: Request -> Proxy cts -> a -> Maybe (LBS, LBS) + resourceHeaders :: Proxy cts -> a -> [(HeaderName, B.ByteString)] + +instance {-# OVERLAPPABLE #-} AllCTRender cts a + => IsServerResource cts a where + resourceResponse request p res = handleAcceptH p (getAcceptHeader request) res + resourceHeaders _ _ = [] + +instance {-# OVERLAPPING #-} (IsServerResource cts a, GetHeaders (Headers h a)) + => IsServerResource cts (Headers h a) where + resourceResponse request p res = resourceResponse request p (getResponse res) + resourceHeaders cts res = getHeaders res ++ resourceHeaders cts (getResponse res) + +instance {-# OVERLAPPING #-} IsServerResource cts a + => IsServerResource cts (WithStatus n a) where + resourceResponse request p (WithStatus x) = resourceResponse request p x + resourceHeaders cts (WithStatus x) = resourceHeaders cts x + +encodeResource :: forall a cts . (IsServerResource cts a, HasStatus a) + => Request -> Proxy cts -> a + -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)]) +encodeResource request cts res = (statusOf (Proxy @a), + resourceResponse request cts res, + resourceHeaders cts res) + +type IsServerResourceWithStatus cts = IsServerResource cts `And` HasStatus + +instance + ( ReflectMethod method, + AllMime contentTypes, + All (IsServerResourceWithStatus contentTypes) as, + Unique (Statuses as) -- for consistency with servant-swagger (server would work fine + -- without; client is a bit of a corner case, because it dispatches + -- the parser based on the status code. with this uniqueness + -- constraint it won't have to run more than one parser in weird + -- corner cases. + ) => + HasServer (UVerb method contentTypes as) context + where + type ServerT (UVerb method contentTypes as) m = m (Union as) + + hoistServerWithContext _ _ nt s = nt s + + route :: + forall env. + Proxy (UVerb method contentTypes as) -> + Context context -> + Delayed env (Server (UVerb method contentTypes as)) -> + Router env + route _proxy _ctx action = leafRouter route' + where + method = reflectMethod (Proxy @method) + route' env request cont = do + let action' :: Delayed env (Handler (Union as)) + action' = + action + `addMethodCheck` methodCheck method request + `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request) + + runAction action' env request cont $ \(output :: Union as) -> do + let cts = Proxy @contentTypes + pickResource :: Union as -> (Status, Maybe (LBS, LBS), [(HeaderName, B.ByteString)]) + pickResource = foldMapUnion (Proxy @(IsServerResourceWithStatus contentTypes)) (encodeResource request cts) + case pickResource output of + (_, Nothing, _) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does + (status, Just (contentT, body), headers) -> + let bdy = if allowedMethodHead method request then "" else body + in Route $ responseLBS status ((hContentType, cs contentT) : headers) bdy diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 8da38bff..e9d880b0 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -12,9 +12,9 @@ import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL -import Data.Monoid - ((<>)) import Data.Proxy +import Data.String.Conversions + (cs) import Network.HTTP.Types (hAccept, hAuthorization, hContentType, methodGet, methodPost, methodPut) @@ -31,6 +31,7 @@ spec = describe "HTTP Errors" $ do prioErrorsSpec errorRetrySpec errorChoiceSpec + customFormattersSpec -- * Auth machinery (reused throughout) @@ -293,6 +294,61 @@ errorChoiceSpec = describe "Multiple handlers return errors" `shouldRespondWith` 415 +-- }}} +------------------------------------------------------------------------------ +-- * Custom errors {{{ + +customFormatter :: ErrorFormatter +customFormatter _ _ err = err400 { errBody = "CUSTOM! " <> cs err } + +customFormatters :: ErrorFormatters +customFormatters = defaultErrorFormatters + { bodyParserErrorFormatter = customFormatter + , urlParseErrorFormatter = customFormatter + , notFoundErrorFormatter = const $ err404 { errBody = "CUSTOM! Not Found" } + } + +type CustomFormatterAPI + = "query" :> QueryParam' '[Required, Strict] "param" Int :> Get '[PlainText] String + :<|> "capture" :> Capture "cap" Bool :> Get '[PlainText] String + :<|> "body" :> ReqBody '[JSON] Int :> Post '[PlainText] String + +customFormatterAPI :: Proxy CustomFormatterAPI +customFormatterAPI = Proxy + +customFormatterServer :: Server CustomFormatterAPI +customFormatterServer = (\_ -> return "query") + :<|> (\_ -> return "capture") + :<|> (\_ -> return "body") + +customFormattersSpec :: Spec +customFormattersSpec = describe "Custom errors from combinators" + $ with (return $ serveWithContext customFormatterAPI (customFormatters :. EmptyContext) customFormatterServer) $ do + + let startsWithCustom = ResponseMatcher + { matchStatus = 400 + , matchHeaders = [] + , matchBody = MatchBody $ \_ body -> if "CUSTOM!" `BCL.isPrefixOf` body + then Nothing + else Just $ show body <> " does not start with \"CUSTOM!\"" + } + + it "formats query parse error" $ do + request methodGet "query?param=false" [] "" + `shouldRespondWith` startsWithCustom + + it "formats query parse error with missing param" $ do + request methodGet "query" [] "" + `shouldRespondWith` startsWithCustom + + it "formats capture parse error" $ do + request methodGet "capture/42" [] "" + `shouldRespondWith` startsWithCustom + + it "formats body parse error" $ do + request methodPost "body" [(hContentType, "application/json")] "foo" + `shouldRespondWith` startsWithCustom + -- }}} ------------------------------------------------------------------------------ -- * Instances {{{ diff --git a/servant-server/test/Servant/Server/Internal/ContextSpec.hs b/servant-server/test/Servant/Server/Internal/ContextSpec.hs index 93e1dcb8..0132f396 100644 --- a/servant-server/test/Servant/Server/Internal/ContextSpec.hs +++ b/servant-server/test/Servant/Server/Internal/ContextSpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} -{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-} +{-# OPTIONS_GHC -fdefer-type-errors -Wwarn -Wno-deferred-type-errors #-} module Servant.Server.Internal.ContextSpec (spec) where import Data.Proxy diff --git a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs index 80210495..04443c9d 100644 --- a/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs +++ b/servant-server/test/Servant/Server/Internal/RoutingApplicationSpec.hs @@ -11,7 +11,7 @@ module Servant.Server.Internal.RoutingApplicationSpec (spec) where import Prelude () import Prelude.Compat -import Control.Exception hiding +import Control.Exception hiding (Handler) import Control.Monad.IO.Class import Control.Monad.Trans.Resource @@ -28,7 +28,7 @@ import Test.Hspec import Test.Hspec.Wai (request, shouldRespondWith, with) -import qualified Data.Text as T +import qualified Data.Text as T import System.IO.Unsafe (unsafePerformIO) diff --git a/servant-server/test/Servant/Server/RouterSpec.hs b/servant-server/test/Servant/Server/RouterSpec.hs index 472dfecc..9b69a2e7 100644 --- a/servant-server/test/Servant/Server/RouterSpec.hs +++ b/servant-server/test/Servant/Server/RouterSpec.hs @@ -32,7 +32,7 @@ routerSpec :: Spec routerSpec = do describe "tweakResponse" $ do let app' :: Application - app' = toApplication $ runRouter router' + app' = toApplication $ runRouter (const err404) router' router', router :: Router () router' = tweakResponse (fmap twk) router @@ -48,7 +48,7 @@ routerSpec = do describe "runRouter" $ do let toApp :: Router () -> Application - toApp = toApplication . runRouter + toApp = toApplication . runRouter (const err404) cap :: Router () cap = CaptureRouter $ diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 265b2aa4..2dc7ad5f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -freduction-depth=100 #-} module Servant.ServerSpec where @@ -49,14 +49,17 @@ import Network.Wai.Test import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, - Delete, EmptyAPI, Get, Header, Headers, HttpVersion, - IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, - NoFraming, OctetStream, Patch, PlainText, Post, Put, - QueryFlag, QueryParam, QueryParams, QueryParamForm, Raw, RemoteHost, ReqBody, - SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader) + Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header, + Headers, HttpVersion, IsSecure (..), JSON, Lenient, + NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch, + PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, QueryParamForm, Raw, + RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict, + UVerb, Union, Verb, WithStatus (..), addHeader) + import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), - emptyServer, err401, err403, err404, serve, serveWithContext) + emptyServer, err401, err403, err404, respond, serve, + serveWithContext) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec @@ -89,15 +92,18 @@ comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext spec :: Spec spec = do verbSpec + uverbSpec captureSpec captureAllSpec queryParamSpec queryParamFormSpec + fragmentSpec reqBodySpec headerSpec rawSpec alternativeSpec responseHeadersSpec + uverbResponseHeadersSpec miscCombinatorSpec basicAuthSpec genAuthSpec @@ -256,8 +262,8 @@ captureSpec = do with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) - (\ "captured" -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + (\ "captured" -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -308,8 +314,8 @@ captureAllSpec = do with (return (serve (Proxy :: Proxy (CaptureAll "segments" String :> Raw)) - (\ _captured -> Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + (\ _captured -> Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do it "consumes everything from pathInfo" $ do get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int]))) @@ -589,6 +595,37 @@ queryParamFormSpec = do liftIO $ do decode' (simpleBody response1) `shouldBe` (Just $ Animal { species = "bimac", numberOfLegs = 1}) +-- }}} +------------------------------------------------------------------------------ +-- * fragmentSpec {{{ +------------------------------------------------------------------------------ + +type FragmentApi = "name" :> Fragment String :> Get '[JSON] Person + :<|> "age" :> Fragment Integer :> Get '[JSON] Person + +fragmentApi :: Proxy FragmentApi +fragmentApi = Proxy + +fragServer :: Server FragmentApi +fragServer = fragmentServer :<|> fragAge + where + fragmentServer = return alice + fragAge = return alice + +fragmentSpec :: Spec +fragmentSpec = do + let mkRequest params pinfo = Network.Wai.Test.request defaultRequest + { rawQueryString = params + , queryString = parseQuery params + , pathInfo = pinfo + } + + describe "Servant.API.Fragment" $ do + it "ignores fragment even if it is present in query" $ do + flip runSession (serve fragmentApi fragServer) $ do + response1 <- mkRequest "#Alice" ["name"] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice + -- }}} ------------------------------------------------------------------------------ -- * reqBodySpec {{{ @@ -674,8 +711,8 @@ rawApi :: Proxy RawApi rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Tagged m Application -rawApplication f = Tagged $ \request_ respond -> - respond $ responseLBS ok200 [] +rawApplication f = Tagged $ \request_ sendResponse -> + sendResponse $ responseLBS ok200 [] (cs $ show $ f request_) rawSpec :: Spec @@ -780,6 +817,31 @@ responseHeadersSpec = describe "ResponseHeaders" $ do THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 +-- }}} +------------------------------------------------------------------------------ +-- * uverbResponseHeaderSpec {{{ +------------------------------------------------------------------------------ +type UVerbHeaderResponse = '[ + WithStatus 200 (Headers '[Header "H1" Int] String), + WithStatus 404 String ] + +type UVerbResponseHeadersApi = + Capture "ok" Bool :> UVerb 'GET '[JSON] UVerbHeaderResponse + +uverbResponseHeadersServer :: Server UVerbResponseHeadersApi +uverbResponseHeadersServer True = respond . WithStatus @200 . addHeader @"H1" (5 :: Int) $ ("foo" :: String) +uverbResponseHeadersServer False = respond . WithStatus @404 $ ("bar" :: String) + +uverbResponseHeadersSpec :: Spec +uverbResponseHeadersSpec = describe "UVerbResponseHeaders" $ do + with (return $ serve (Proxy :: Proxy UVerbResponseHeadersApi) uverbResponseHeadersServer) $ do + + it "includes the headers in the response" $ + THW.request methodGet "/true" [] "" + `shouldRespondWith` "\"foo\"" { matchHeaders = ["H1" <:> "5"] + , matchStatus = 200 + } + -- }}} ------------------------------------------------------------------------------ -- * miscCombinatorSpec {{{ @@ -836,7 +898,7 @@ basicAuthApi = Proxy basicAuthServer :: Server BasicAuthAPI basicAuthServer = const (return jerry) :<|> - (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") basicAuthContext :: Context '[ BasicAuthCheck () ] basicAuthContext = @@ -881,7 +943,7 @@ genAuthApi = Proxy genAuthServer :: Server GenAuthAPI genAuthServer = const (return tweety) - :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "") + :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "") type instance AuthServerData (AuthProtect "auth") = () @@ -911,6 +973,73 @@ genAuthSpec = do it "plays nice with subsequent Raw endpoints" $ do get "/foo" `shouldRespondWith` 418 +-- }}} +------------------------------------------------------------------------------ +-- * UVerb {{{ +------------------------------------------------------------------------------ + +newtype PersonResponse = PersonResponse Person + deriving Generic +instance ToJSON PersonResponse +instance HasStatus PersonResponse where + type StatusOf PersonResponse = 200 + +newtype RedirectResponse = RedirectResponse String + deriving Generic +instance ToJSON RedirectResponse +instance HasStatus RedirectResponse where + type StatusOf RedirectResponse = 301 + +newtype AnimalResponse = AnimalResponse Animal + deriving Generic +instance ToJSON AnimalResponse +instance HasStatus AnimalResponse where + type StatusOf AnimalResponse = 203 + + +type UVerbApi + = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse] + :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse] + +uverbSpec :: Spec +uverbSpec = describe "Servant.API.UVerb " $ do + let + joe = Person "joe" 42 + mouse = Animal "Mouse" 7 + + personHandler + :: Bool + -> Handler (Union '[PersonResponse + ,RedirectResponse]) + personHandler True = respond $ RedirectResponse "over there!" + personHandler False = respond $ PersonResponse joe + + animalHandler = respond $ AnimalResponse mouse + + server :: Server UVerbApi + server = personHandler :<|> animalHandler + + with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do + context "A route returning either 301/String or 200/Person" $ do + context "when requesting the person" $ do + let theRequest = THW.get "/person/false" + it "returns status 200" $ + theRequest `shouldRespondWith` 200 + it "returns a person" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just joe + context "requesting the redirect" $ + it "returns a message and status 301" $ + THW.get "/person/true" + `shouldRespondWith` "\"over there!\"" {matchStatus = 301} + context "a route with a single response type" $ do + let theRequest = THW.get "/animal" + it "should return the defined status code" $ + theRequest `shouldRespondWith` 203 + it "should return the expected response" $ do + response <- theRequest + liftIO $ decode' (simpleBody response) `shouldBe` Just mouse + -- }}} ------------------------------------------------------------------------------ -- * Test data types {{{ diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 8414624d..8c58ed7b 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,5 +1,160 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md) +0.18.3 +------ + +### Significant changes + +- Add response header support to UVerb (#1420). +- Use Capture Description if available (#1423). + +### Other changes + +- Support GHC-9.0.1. +- Bump `bytestring`, `attoparsec`, `hspec` and `singleton-bool` dependencies. + +0.18.2 +------ + +### Significant changes + +- Introduce `Fragment` combinator. +- Fix `MimeRender` and `MimeUnrender` instances for `WithStatus`. + +0.18.1 +------ + +### Significant changes + +- Union verbs + +### Other changes + +- Bump "tested-with" ghc versions +- Allow newer dependencies + +0.18 +---- + +### Significant changes + +- Support for ghc8.8 (#1318, #1326, #1327) + +- Configurable error messages for automatic errors thrown by servant, + like "no route" or "could not parse json body" (#1312, #1326, #1327) + +### Other changes + +- Witness that a type-level natural number corresponds to a HTTP + status code (#1310) + +- Improve haddocs (#1279) + +- Dependency management (#1269, #1293, #1286, #1287) + + +0.17 +---- + +### Significant changes + +- Add NoContentVerb [#1028](https://github.com/haskell-servant/servant/issues/1028) [#1219](https://github.com/haskell-servant/servant/pull/1219) [#1228](https://github.com/haskell-servant/servant/pull/1228) + + 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. + +- `Capture` can be `Lenient` [#1155](https://github.com/haskell-servant/servant/issues/1155) [#1156](https://github.com/haskell-servant/servant/pull/1156) + + 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. + +- *servant-client* Added a function to create Client.Request in ClientEnv [#1213](https://github.com/haskell-servant/servant/pull/1213) [#1255](https://github.com/haskell-servant/servant/pull/1255) + + 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. + +- *servant-server* use queryString to parse QueryParam, QueryParams and QueryFlag [#1249](https://github.com/haskell-servant/servant/pull/1249) [#1262](https://github.com/haskell-servant/servant/pull/1262) + + 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 modifying + request's `Query`. But QueryParam, QueryParams and QueryFlag use + `rawQueryString`. By using `queryString` rather then `rawQueryString` + we can enable such rewritings. + +- *servant* *servant-server* Make packages `build-type: Simple` [#1263](https://github.com/haskell-servant/servant/pull/1263) + + 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 conveniently). + +- *servant* Remove deprecated modules [1268#](https://github.com/haskell-servant/servant/pull/1268) + + - `Servant.Utils.Links` is `Servant.Links` + - `Servant.API.Internal.Test.ComprehensiveAPI` is `Servant.Test.ComprehensiveAPI` + +### Other changes + +- *servant-client* *servant-client-core* *servant-http-streams* Fix Verb with headers checking content type differently [#1200](https://github.com/haskell-servant/servant/issues/1200) [#1204](https://github.com/haskell-servant/servant/pull/1204) + + For `Verb`s with response `Headers`, the implementation didn't check + for the content-type of the response. Now it does. + +- *servant-docs* Merge documentation from duplicate routes [#1240](https://github.com/haskell-servant/servant/issues/1240) [#1241](https://github.com/haskell-servant/servant/pull/1241) + + 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. + +- Add sponsorship button [#1190](https://github.com/haskell-servant/servant/pull/1190) + + [Well-Typed](https://www.well-typed.com/) is a consultancy which could help you with `servant` issues + (See consultancies section on https://www.servant.dev/). + +- Try changelog-d for changelog management [#1230](https://github.com/haskell-servant/servant/pull/1230) + + Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details + +- CI and testing tweaks. [#1154](https://github.com/haskell-servant/servant/pull/1154) [#1157](https://github.com/haskell-servant/servant/pull/1157) [#1182](https://github.com/haskell-servant/servant/pull/1182) [#1214](https://github.com/haskell-servant/servant/pull/1214) [#1229](https://github.com/haskell-servant/servant/pull/1229) [#1233](https://github.com/haskell-servant/servant/pull/1233) [#1242](https://github.com/haskell-servant/servant/pull/1242) [#1247](https://github.com/haskell-servant/servant/pull/1247) [#1250](https://github.com/haskell-servant/servant/pull/1250) [#1258](https://github.com/haskell-servant/servant/pull/1258) + + We are experiencing some bitrotting of cookbook recipe dependencies, + therefore some of them aren't build as part of our CI anymore. + +- New cookbook recipes [#1088](https://github.com/haskell-servant/servant/pull/1088) [#1171](https://github.com/haskell-servant/servant/pull/1171) [#1198](https://github.com/haskell-servant/servant/pull/1198) + + - [OIDC Recipe](#TODO) + - [MySQL Recipe](#TODO) + +- *servant-jsaddle* Progress on servant-jsaddle [#1216](https://github.com/haskell-servant/servant/pull/1216) +- *servant-docs* Prevent race-conditions in testing [#1194](https://github.com/haskell-servant/servant/pull/1194) +- *servant-client* *servant-http-streams* `HasClient` instance for `Stream` with `Headers` [#1170](https://github.com/haskell-servant/servant/issues/1170) [#1197](https://github.com/haskell-servant/servant/pull/1197) +- *servant* Remove unused extensions from cabal file [#1201](https://github.com/haskell-servant/servant/pull/1201) +- *servant-client* Redact the authorization header in Show and exceptions [#1238](https://github.com/haskell-servant/servant/pull/1238) +- Dependency upgrades [#1173](https://github.com/haskell-servant/servant/pull/1173) [#1181](https://github.com/haskell-servant/servant/pull/1181) [#1183](https://github.com/haskell-servant/servant/pull/1183) [#1188](https://github.com/haskell-servant/servant/pull/1188) [#1224](https://github.com/haskell-servant/servant/pull/1224) [#1245](https://github.com/haskell-servant/servant/pull/1245) [#1257](https://github.com/haskell-servant/servant/pull/1257) +- Documentation updates [#1162](https://github.com/haskell-servant/servant/pull/1162) [#1174](https://github.com/haskell-servant/servant/pull/1174) [#1175](https://github.com/haskell-servant/servant/pull/1175) [#1234](https://github.com/haskell-servant/servant/pull/1234) [#1244](https://github.com/haskell-servant/servant/pull/1244) [#1247](https://github.com/haskell-servant/servant/pull/1247) + + 0.16.2 ------ @@ -303,7 +458,7 @@ - *servant-client-core* Add `hoistClient` to `HasClient`. Just like `hoistServer` allows us to change the monad in which request handlers - of a web application live in, we also have `hoistClient` for changing the monad + of a web application live, we also have `hoistClient` for changing the monad in which *client functions* live. Read [tutorial section for more information](https://docs.servant.dev/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in). ([#936](https://github.com/haskell-servant/servant/pull/936)) @@ -510,7 +665,7 @@ `enter` isn't exported from `Servant` module anymore. You can change `enter` to `hoistServer` in a straight forward way. - Unwrap natural transformation and add a api type `Proxy`: + Unwrap natural transformation and add an api type `Proxy`: ```diff -server = enter (NT nt) impl diff --git a/servant/servant.cabal b/servant/servant.cabal index 120fce72..8b6fe355 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant -version: 0.16 +version: 0.18.3 synopsis: A family of combinators for defining webservices APIs category: Servant, Web @@ -13,20 +13,15 @@ description: homepage: http://docs.servant.dev/ bug-reports: http://github.com/haskell-servant/servant/issues -license: BSD3 +license: BSD-3-Clause 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: Simple -tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.1 - , GHCJS == 8.4 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.2 || ==9.0.1 + , GHCJS ==8.6.0.1 extra-source-files: CHANGELOG.md @@ -45,6 +40,7 @@ library Servant.API.Description Servant.API.Empty Servant.API.Experimental.Auth + Servant.API.Fragment Servant.API.Generic Servant.API.Header Servant.API.HttpVersion @@ -55,9 +51,12 @@ library Servant.API.RemoteHost Servant.API.ReqBody Servant.API.ResponseHeaders + Servant.API.Status Servant.API.Stream Servant.API.Sub Servant.API.TypeLevel + Servant.API.UVerb + Servant.API.UVerb.Union Servant.API.Vault Servant.API.Verbs Servant.API.WithNamedContext @@ -74,19 +73,15 @@ library exposed-modules: Servant.Links - -- Deprecated modules, to be removed in late 2019 - exposed-modules: - Servant.Utils.Links - Servant.API.Internal.Test.ComprehensiveAPI - -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.9 && < 4.14 - , bytestring >= 0.10.8.1 && < 0.11 + base >= 4.9 && < 4.16 + , bytestring >= 0.10.8.1 && < 0.12 , mtl >= 2.2.2 && < 2.3 + , sop-core >= 0.4.0.0 && < 0.6 , transformers >= 0.5.2.0 && < 0.6 , text >= 1.2.3.0 && < 1.3 @@ -94,15 +89,15 @@ library -- We depend (heavily) on the API of these packages: -- i.e. re-export, or allow using without direct dependency build-depends: - http-api-data >= 0.4.1 && < 0.4.2 - , singleton-bool >= 0.1.4 && < 0.1.6 + http-api-data >= 0.4.1 && < 0.4.4 + , singleton-bool >= 0.1.4 && < 0.1.7 -- Other dependencies: Lower bound around what is in the latest Stackage LTS. -- Here can be exceptions if we really need features from the newer versions. build-depends: base-compat >= 0.10.5 && < 0.12 - , aeson >= 1.4.1.0 && < 1.5 - , attoparsec >= 0.13.2.2 && < 0.14 + , aeson >= 1.4.1.0 && < 1.6 + , attoparsec >= 0.13.2.2 && < 0.15 , bifunctors >= 5.5.3 && < 5.6 , case-insensitive >= 1.2.0.11 && < 1.3 , deepseq >= 1.4.2.0 && < 1.5 @@ -110,18 +105,20 @@ library , http-types >= 0.12.2 && < 0.13 , mmorph >= 1.1.2 && < 1.2 , network-uri >= 2.6.1.0 && < 2.7 - , QuickCheck >= 2.12.6.1 && < 2.14 + , QuickCheck >= 2.12.6.1 && < 2.15 , string-conversions >= 0.4.0.1 && < 0.5 , tagged >= 0.8.6 && < 0.9 , vault >= 0.3.1.2 && < 0.4 hs-source-dirs: src default-language: Haskell2010 - other-extensions: CPP + other-extensions: AllowAmbiguousTypes + , CPP , ConstraintKinds , DataKinds , DeriveDataTypeable , DeriveGeneric + , ExplicitNamespaces , FlexibleContexts , FlexibleInstances , FunctionalDependencies @@ -130,11 +127,13 @@ library , MultiParamTypeClasses , OverloadedStrings , PolyKinds + , RankNTypes , ScopedTypeVariables , TupleSections , TypeFamilies , TypeOperators , UndecidableInstances + ghc-options: -Wall -Wno-redundant-constraints test-suite spec @@ -163,11 +162,11 @@ test-suite spec , text , transformers - -- Additonal dependencies + -- Additional dependencies build-depends: - hspec >= 2.6.0 && < 2.8 - , QuickCheck >= 2.12.6.1 && < 2.14 + hspec >= 2.6.0 && < 2.9 + , QuickCheck >= 2.12.6.1 && < 2.15 , quickcheck-instances >= 0.3.19 && < 0.4 build-tool-depends: - hspec-discover:hspec-discover >= 2.6.0 && < 2.8 + hspec-discover:hspec-discover >= 2.6.0 && < 2.9 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index dcb0efac..134624c8 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -19,6 +19,8 @@ module Servant.API ( -- | Retrieving the HTTP version of the request module Servant.API.QueryParam, -- | Retrieving parameters from the query string of the 'URI': @'QueryParam'@ + module Servant.API.Fragment, + -- | Documenting the fragment of the 'URI': @'Fragment'@ module Servant.API.ReqBody, -- | Accessing the request body as a JSON-encoded type: @'ReqBody'@ module Servant.API.RemoteHost, @@ -32,6 +34,7 @@ module Servant.API ( -- * Actual endpoints, distinguished by HTTP method module Servant.API.Verbs, + module Servant.API.UVerb, -- * Streaming endpoints, distinguished by HTTP method module Servant.API.Stream, @@ -95,6 +98,8 @@ import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) +import Servant.API.Fragment + (Fragment) import Servant.API.Header (Header, Header') import Servant.API.HttpVersion @@ -124,18 +129,20 @@ import Servant.API.Stream ToSourceIO (..)) import Servant.API.Sub ((:>)) +import Servant.API.UVerb + (HasStatus, IsMember, StatusOf, Statuses, UVerb, Union, + Unique, WithStatus (..), inject, statusOf) import Servant.API.Vault (Vault) import Servant.API.Verbs (Delete, DeleteAccepted, DeleteNoContent, DeleteNonAuthoritative, Get, GetAccepted, GetNoContent, GetNonAuthoritative, GetPartialContent, GetResetContent, - Patch, PatchAccepted, PatchNoContent, PatchNonAuthoritative, - Post, PostAccepted, PostCreated, PostNoContent, - PostNonAuthoritative, PostResetContent, Put, PutAccepted, - PutCreated, PutNoContent, PutNonAuthoritative, - ReflectMethod (reflectMethod), StdMethod (..), - Verb, NoContentVerb) + NoContentVerb, Patch, PatchAccepted, PatchNoContent, + PatchNonAuthoritative, Post, PostAccepted, PostCreated, + PostNoContent, PostNonAuthoritative, PostResetContent, Put, + PutAccepted, PutCreated, PutNoContent, PutNonAuthoritative, + ReflectMethod (reflectMethod), StdMethod (..), Verb) import Servant.API.WithNamedContext (WithNamedContext) import Servant.Links diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 60152ac1..e87dd394 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -16,8 +16,6 @@ import Data.Bifunctor (Bifunctor (..)) import Data.Bitraversable (Bitraversable (..)) -import Data.Semigroup - (Semigroup (..)) import Data.Typeable (Typeable) import Prelude () diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index 145ecfb5..10e8d896 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,7 +21,7 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: -- --- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book +-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Put '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@ -- or @text/plain;charset-utf8@, and returns data in either one of those @@ -419,7 +420,6 @@ instance MimeUnrender OctetStream BS.ByteString where mimeUnrender _ = Right . toStrict - -- $setup -- >>> :set -XFlexibleInstances -- >>> :set -XMultiParamTypeClasses diff --git a/servant/src/Servant/API/Fragment.hs b/servant/src/Servant/API/Fragment.hs new file mode 100644 index 00000000..dd9befaa --- /dev/null +++ b/servant/src/Servant/API/Fragment.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_HADDOCK not-home #-} +module Servant.API.Fragment (Fragment) where + +import Data.Typeable + (Typeable) + +-- | Document the URI fragment in API. Useful in combination with 'Link'. +-- +-- Example: +-- +-- >>> -- /post#TRACKING +-- >>> type MyApi = "post" :> Fragment Text :> Get '[JSON] Tracking +data Fragment (a :: *) + deriving Typeable + +-- $setup +-- >>> import Servant.API +-- >>> import Data.Aeson +-- >>> import Data.Text +-- >>> data Tracking +-- >>> instance ToJSON Tracking where { toJSON = undefined } diff --git a/servant/src/Servant/API/Header.hs b/servant/src/Servant/API/Header.hs index 14562dfc..e5ea1e00 100644 --- a/servant/src/Servant/API/Header.hs +++ b/servant/src/Servant/API/Header.hs @@ -23,7 +23,7 @@ import Servant.API.Modifiers -- >>> type MyApi = "view-my-referer" :> Header "from" Referer :> Get '[JSON] Referer type Header = Header' '[Optional, Strict] -data Header' (mods :: [*]) (sym :: Symbol) a +data Header' (mods :: [*]) (sym :: Symbol) (a :: *) deriving Typeable -- $setup diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs deleted file mode 100644 index ee2609ca..00000000 --- a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Servant.API.Internal.Test.ComprehensiveAPI - {-# DEPRECATED "Use Servant.TestComprehensiveAPI" #-} - ( module Servant.Test.ComprehensiveAPI ) - where - -import Servant.Test.ComprehensiveAPI diff --git a/servant/src/Servant/API/Modifiers.hs b/servant/src/Servant/API/Modifiers.hs index 7979ac15..3714fd3a 100644 --- a/servant/src/Servant/API/Modifiers.hs +++ b/servant/src/Servant/API/Modifiers.hs @@ -131,8 +131,6 @@ type RequestArgument mods a = (If (FoldLenient mods) (Either Text a) a) (Maybe (If (FoldLenient mods) (Either Text a) a)) - - -- | Unfold a value into a 'RequestArgument'. unfoldRequestArgument :: forall mods m a. (Monad m, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 6ca42b6f..0ec60e22 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -51,6 +51,9 @@ import Web.HttpApiData import Prelude () import Prelude.Compat +import Servant.API.ContentTypes + (JSON, PlainText, FormUrlEncoded, OctetStream, + MimeRender(..)) import Servant.API.Header (Header) @@ -95,7 +98,7 @@ type family HeaderValMap (f :: * -> *) (xs :: [*]) where class BuildHeadersTo hs where buildHeadersTo :: [HTTP.Header] -> HList hs - -- ^ Note: if there are multiple occurences of a header in the argument, + -- ^ Note: if there are multiple occurrences of a header in the argument, -- the values are interspersed with commas before deserialization (see -- ) diff --git a/servant/src/Servant/API/Status.hs b/servant/src/Servant/API/Status.hs new file mode 100644 index 00000000..ee334fcd --- /dev/null +++ b/servant/src/Servant/API/Status.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DataKinds #-} +-- Flexible instances is necessary on GHC 8.4 and earlier +{-# LANGUAGE FlexibleInstances #-} +module Servant.API.Status where + +import Network.HTTP.Types.Status +import GHC.TypeLits + +-- | Witness that a type-level natural number corresponds to a HTTP status code +class KnownNat n => KnownStatus n where + statusVal :: proxy n -> Status + +instance KnownStatus 100 where + statusVal _ = status100 + +instance KnownStatus 101 where + statusVal _ = status101 + +instance KnownStatus 200 where + statusVal _ = status200 + +instance KnownStatus 201 where + statusVal _ = status201 + +instance KnownStatus 202 where + statusVal _ = status202 + +instance KnownStatus 203 where + statusVal _ = status203 + +instance KnownStatus 204 where + statusVal _ = status204 + +instance KnownStatus 205 where + statusVal _ = status205 + +instance KnownStatus 206 where + statusVal _ = status206 + +instance KnownStatus 300 where + statusVal _ = status300 + +instance KnownStatus 301 where + statusVal _ = status301 + +instance KnownStatus 302 where + statusVal _ = status302 + +instance KnownStatus 303 where + statusVal _ = status303 + +instance KnownStatus 304 where + statusVal _ = status304 + +instance KnownStatus 305 where + statusVal _ = status305 + +instance KnownStatus 307 where + statusVal _ = status307 + +instance KnownStatus 308 where + statusVal _ = status308 + +instance KnownStatus 400 where + statusVal _ = status400 + +instance KnownStatus 401 where + statusVal _ = status401 + +instance KnownStatus 402 where + statusVal _ = status402 + +instance KnownStatus 403 where + statusVal _ = status403 + +instance KnownStatus 404 where + statusVal _ = status404 + +instance KnownStatus 405 where + statusVal _ = status405 + +instance KnownStatus 406 where + statusVal _ = status406 + +instance KnownStatus 407 where + statusVal _ = status407 + +instance KnownStatus 408 where + statusVal _ = status408 + +instance KnownStatus 409 where + statusVal _ = status409 + +instance KnownStatus 410 where + statusVal _ = status410 + +instance KnownStatus 411 where + statusVal _ = status411 + +instance KnownStatus 412 where + statusVal _ = status412 + +instance KnownStatus 413 where + statusVal _ = status413 + +instance KnownStatus 414 where + statusVal _ = status414 + +instance KnownStatus 415 where + statusVal _ = status415 + +instance KnownStatus 416 where + statusVal _ = status416 + +instance KnownStatus 417 where + statusVal _ = status417 + +instance KnownStatus 418 where + statusVal _ = status418 + +instance KnownStatus 422 where + statusVal _ = status422 + +instance KnownStatus 426 where + statusVal _ = status426 + +instance KnownStatus 428 where + statusVal _ = status428 + +instance KnownStatus 429 where + statusVal _ = status429 + +instance KnownStatus 431 where + statusVal _ = status431 + +instance KnownStatus 500 where + statusVal _ = status500 + +instance KnownStatus 501 where + statusVal _ = status501 + +instance KnownStatus 502 where + statusVal _ = status502 + +instance KnownStatus 503 where + statusVal _ = status503 + +instance KnownStatus 504 where + statusVal _ = status504 + +instance KnownStatus 505 where + statusVal _ = status505 + +instance KnownStatus 511 where + statusVal _ = status511 diff --git a/servant/src/Servant/API/Stream.hs b/servant/src/Servant/API/Stream.hs index 64164f5a..6f6a59cf 100644 --- a/servant/src/Servant/API/Stream.hs +++ b/servant/src/Servant/API/Stream.hs @@ -47,8 +47,6 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LBS8 import Data.List.NonEmpty (NonEmpty (..)) -import Data.Monoid - ((<>)) import Data.Proxy (Proxy) import Data.Typeable diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 862cae22..14ecdee1 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -1,12 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-| This module collects utilities for manipulating @servant@ API types. The @@ -41,6 +45,9 @@ module Servant.API.TypeLevel ( -- ** Logic Or, And, + -- ** Fragment + FragmentUnique, + AtLeastOneFragment ) where @@ -50,6 +57,7 @@ import Servant.API.Alternative (type (:<|>)) import Servant.API.Capture (Capture, CaptureAll) +import Servant.API.Fragment import Servant.API.Header (Header) import Servant.API.QueryParam @@ -60,6 +68,8 @@ import Servant.API.Sub (type (:>)) import Servant.API.Verbs (Verb) +import Servant.API.UVerb + (UVerb) import GHC.TypeLits (ErrorMessage (..), TypeError) @@ -129,6 +139,7 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryParamForm x :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb + IsElem sa (Fragment x :> sb) = IsElem sa sb IsElem (Verb m s ct typ) (Verb m s ct' typ) = IsSubList ct ct' IsElem e e = () @@ -242,6 +253,43 @@ We might try to factor these our more cleanly, but the type synonyms and type families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -} +-- ** Fragment + +class FragmentUnique api => AtLeastOneFragment api + +-- | If fragment appeared in API endpoint twice, compile-time error would be raised. +-- +-- >>> -- type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent +-- >>> instance AtLeastOneFragment FailAPI +-- ... +-- ...Only one Fragment allowed per endpoint in api... +-- ... +-- ...In the instance declaration for... +instance AtLeastOneFragment (Verb m s ct typ) + +instance AtLeastOneFragment (UVerb m cts as) + +instance AtLeastOneFragment (Fragment a) + +type family FragmentUnique api :: Constraint where + FragmentUnique (sa :<|> sb) = And (FragmentUnique sa) (FragmentUnique sb) + FragmentUnique (Fragment a :> sa) = FragmentNotIn sa (Fragment a :> sa) + FragmentUnique (x :> sa) = FragmentUnique sa + FragmentUnique (Fragment a) = () + FragmentUnique x = () + +type family FragmentNotIn api orig :: Constraint where + FragmentNotIn (sa :<|> sb) orig = + And (FragmentNotIn sa orig) (FragmentNotIn sb orig) + FragmentNotIn (Fragment c :> sa) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn (x :> sa) orig = FragmentNotIn sa orig + FragmentNotIn (Fragment c) orig = TypeError (NotUniqueFragmentInApi orig) + FragmentNotIn x orig = () + +type NotUniqueFragmentInApi api = + 'Text "Only one Fragment allowed per endpoint in api ‘" + ':<>: 'ShowType api + ':<>: 'Text "’." -- $setup -- @@ -249,6 +297,7 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -- -- >>> :set -XPolyKinds -- >>> :set -XGADTs +-- >>> :set -XTypeSynonymInstances -XFlexibleInstances -- >>> import Data.Proxy -- >>> import Data.Type.Equality -- >>> import Servant.API @@ -256,4 +305,5 @@ families are not evaluated (see https://ghc.haskell.org/trac/ghc/ticket/12048). -- >>> instance Show (OK ctx) where show _ = "OK" -- >>> let ok :: ctx => Proxy ctx -> OK ctx; ok _ = OK -- >>> type SampleAPI = "hello" :> Get '[JSON] Int :<|> "bye" :> Capture "name" String :> Post '[JSON, PlainText] Bool +-- >>> type FailAPI = Fragment Bool :> Fragment Int :> Get '[JSON] NoContent -- >>> let sampleAPI = Proxy :: Proxy SampleAPI diff --git a/servant/src/Servant/API/UVerb.hs b/servant/src/Servant/API/UVerb.hs new file mode 100644 index 00000000..ed59eded --- /dev/null +++ b/servant/src/Servant/API/UVerb.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an +-- open union of types, and specific status codes for each type in this union. (`UVerb` is +-- short for `UnionVerb`) +-- +-- This can be used for returning (rather than throwing) exceptions in a server as in, say +-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or +-- 201 created with a different body type, depending on the circumstances. (All of this can +-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in +-- the API types without something like `UVerb`.) +-- +-- See for a working example. +module Servant.API.UVerb + ( UVerb, + HasStatus (StatusOf), + statusOf, + HasStatuses (Statuses, statuses), + WithStatus (..), + module Servant.API.UVerb.Union, + ) +where + +import Data.Proxy (Proxy (Proxy)) +import GHC.TypeLits (Nat) +import Network.HTTP.Types (Status, StdMethod) +import Servant.API.ContentTypes (JSON, PlainText, FormUrlEncoded, OctetStream, NoContent, MimeRender(mimeRender), MimeUnrender(mimeUnrender)) +import Servant.API.Status (KnownStatus, statusVal) +import Servant.API.UVerb.Union + +class KnownStatus (StatusOf a) => HasStatus (a :: *) where + type StatusOf (a :: *) :: Nat + +statusOf :: forall a proxy. HasStatus a => proxy a -> Status +statusOf = const (statusVal (Proxy :: Proxy (StatusOf a))) + +-- | If an API can respond with 'NoContent' we assume that this will happen +-- with the status code 204 No Content. If this needs to be overridden, +-- 'WithStatus' can be used. +instance HasStatus NoContent where + type StatusOf NoContent = 204 + +class HasStatuses (as :: [*]) where + type Statuses (as :: [*]) :: [Nat] + statuses :: Proxy as -> [Status] + +instance HasStatuses '[] where + type Statuses '[] = '[] + statuses _ = [] + +instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where + type Statuses (a ': as) = StatusOf a ': Statuses as + statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as) + +-- | A simple newtype wrapper that pairs a type with its status code. It +-- implements all the content types that Servant ships with by default. +newtype WithStatus (k :: Nat) a = WithStatus a + deriving (Eq, Show) + +-- | an instance of this typeclass assigns a HTTP status code to a return type +-- +-- Example: +-- +-- @ +-- data NotFoundError = NotFoundError String +-- +-- instance HasStatus NotFoundError where +-- type StatusOf NotFoundError = 404 +-- @ +-- +-- You can also use the convience newtype wrapper 'WithStatus' if you want to +-- avoid writing a 'HasStatus' instance manually. It also has the benefit of +-- showing the status code in the type; which might aid in readability. +instance KnownStatus n => HasStatus (WithStatus n a) where + type StatusOf (WithStatus n a) = n + + +-- | A variant of 'Verb' that can have any of a number of response values and status codes. +-- +-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write +-- instances for 'HasServer' etc. for the latter, getting them for the former for free. +-- Something like: +-- +-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@ +-- +-- Backwards compatibility is tricky, though: this type alias would mean people would have to +-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten. +data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*]) + +instance {-# OVERLAPPING #-} MimeRender JSON a => MimeRender JSON (WithStatus _status a) where + mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a + +instance {-# OVERLAPPING #-} MimeRender PlainText a => MimeRender PlainText (WithStatus _status a) where + mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a + +instance {-# OVERLAPPING #-} MimeRender FormUrlEncoded a => MimeRender FormUrlEncoded (WithStatus _status a) where + mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a + +instance {-# OVERLAPPING #-} MimeRender OctetStream a => MimeRender OctetStream (WithStatus _status a) where + mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a + +instance {-# OVERLAPPING #-} MimeUnrender JSON a => MimeUnrender JSON (WithStatus _status a) where + mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input + +instance {-# OVERLAPPING #-} MimeUnrender PlainText a => MimeUnrender PlainText (WithStatus _status a) where + mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input + +instance {-# OVERLAPPING #-} MimeUnrender FormUrlEncoded a => MimeUnrender FormUrlEncoded (WithStatus _status a) where + mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input + +instance {-# OVERLAPPING #-} MimeUnrender OctetStream a => MimeUnrender OctetStream (WithStatus _status a) where + mimeUnrender contentTypeProxy input = WithStatus <$> mimeUnrender contentTypeProxy input diff --git a/servant/src/Servant/API/UVerb/Union.hs b/servant/src/Servant/API/UVerb/Union.hs new file mode 100644 index 00000000..11d93e74 --- /dev/null +++ b/servant/src/Servant/API/UVerb/Union.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{- + +Copyright Dennis Gosnell (c) 2017-2018 + +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 Author name here 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. + +-} + +-- | Type-level code for implementing and using 'UVerb'. Heavily inspired by +-- [world-peace](https://github.com/cdepillabout/world-peace). +module Servant.API.UVerb.Union +( IsMember +, Unique +, Union +, inject +, eject +, foldMapUnion +, matchUnion +) +where + +import Data.Proxy (Proxy) +import Data.SOP.BasicFunctors (I, unI) +import Data.SOP.Constraint +import Data.SOP.NS +import Data.Type.Bool (If) +import Data.Type.Equality (type (==)) +import GHC.TypeLits + +type Union = NS I + +-- | Convenience function to apply a function to an unknown union element using a type class. +-- All elements of the union must have instances in the type class, and the function is +-- applied unconditionally. +-- +-- See also: 'matchUnion'. +foldMapUnion :: + forall (c :: * -> Constraint) (a :: *) (as :: [*]). + All c as => + Proxy c -> + (forall x. c x => x -> a) -> + Union as -> + a +foldMapUnion proxy go = cfoldMap_NS proxy (go . unI) + +-- | Convenience function to extract a union element using 'cast', ie. return the value if the +-- selected type happens to be the actual type of the union in this value, or 'Nothing' +-- otherwise. +-- +-- See also: 'foldMapUnion'. +matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a +matchUnion = fmap unI . eject + +-- * Stuff stolen from 'Data.WorldPeace" but for generics-sop + +-- (this could to go sop-core, except it's probably too specialized to the servant use-case.) + +type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as) + +class UElem x xs where + inject :: f x -> NS f xs + eject :: NS f xs -> Maybe (f x) + +instance {-# OVERLAPPING #-} UElem x (x ': xs) where + inject = Z + eject (Z x) = Just x + eject _ = Nothing + +instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where + inject = S . inject + eject (Z _) = Nothing + eject (S ns) = eject ns + +-- | Check whether @a@ is in list. This will throw nice errors if the element is not in the +-- list, or if there is a duplicate in the list. +type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where + CheckElemIsMember a as = + If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as)) + +type NoElementError (r :: k) (rs :: [k]) = + 'Text "Expected one of:" + ':$$: 'Text " " ':<>: 'ShowType rs + ':$$: 'Text "But got:" + ':$$: 'Text " " ':<>: 'ShowType r + +type DuplicateElementError (rs :: [k]) = + 'Text "Duplicate element in list:" + ':$$: 'Text " " ':<>: 'ShowType rs + +type family Elem (x :: k) (xs :: [k]) :: Bool where + Elem _ '[] = 'False + Elem x (x' ': xs) = + If (x == x') 'True (Elem x xs) + +type family Unique xs :: Constraint where + Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs)) + +type family Nubbed xs :: Bool where + Nubbed '[] = 'True + Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs) + +_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False + , Nubbed '[Int, Int, Bool] ~ 'False + , Nubbed '[Int, Bool] ~ 'True + ) + => a) -> a +_testNubbed a = a diff --git a/servant/src/Servant/Links.hs b/servant/src/Servant/Links.hs index ba6e73a0..5c4e84a5 100644 --- a/servant/src/Servant/Links.hs +++ b/servant/src/Servant/Links.hs @@ -17,6 +17,7 @@ -- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators -- >>> import Servant.API -- >>> import Servant.Links +-- >>> import Web.HttpApiData (toUrlPiece) -- >>> import Data.Proxy -- >>> -- >>> type Hello = "hello" :> Get '[JSON] Int @@ -54,7 +55,7 @@ -- >>> toUrlPiece $ safeLink api without -- "bye" -- --- If you would like create a helper for generating links only within that API, +-- If you would like to create a helper for generating links only within that API, -- you can partially apply safeLink if you specify a correct type signature -- like so: -- @@ -65,7 +66,7 @@ -- >>> apiLink = safeLink api -- >>> :} -- --- `safeLink'` allows to make specialise the output: +-- `safeLink'` allows you to specialise the output: -- -- >>> safeLink' toUrlPiece api without -- "bye" @@ -120,6 +121,7 @@ module Servant.Links ( , Param (..) , linkSegments , linkQueryParams + , linkFragment ) where import qualified Data.ByteString.Lazy as LBS @@ -127,8 +129,6 @@ import qualified Data.ByteString.Lazy.Char8 as LBSC import Data.List import Data.Proxy (Proxy (..)) -import Data.Semigroup - ((<>)) import Data.Singletons.Bool (SBool (..), SBoolI (..)) import qualified Data.Text as Text @@ -156,6 +156,8 @@ import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) +import Servant.API.Fragment + (Fragment) import Servant.API.Generic import Servant.API.Header (Header') @@ -178,6 +180,7 @@ import Servant.API.Stream import Servant.API.Sub (type (:>)) import Servant.API.TypeLevel +import Servant.API.UVerb import Servant.API.Vault (Vault) import Servant.API.Verbs @@ -192,10 +195,13 @@ import Web.HttpApiData data Link = Link { _segments :: [Escaped] , _queryParams :: [Param] + , _fragment :: Fragment' } deriving Show newtype Escaped = Escaped String +type Fragment' = Maybe String + escaped :: String -> Escaped escaped = Escaped . escapeURIString isUnreserved @@ -212,11 +218,14 @@ linkSegments = map getEscaped . _segments linkQueryParams :: Link -> [Param] linkQueryParams = _queryParams +linkFragment :: Link -> Fragment' +linkFragment = _fragment + instance ToHttpApiData Link where toHeader = TE.encodeUtf8 . toUrlPiece toUrlPiece l = let uri = linkURI l - in Text.pack $ uriPath uri ++ uriQuery uri + in Text.pack $ uriPath uri ++ uriQuery uri ++ uriFragment uri -- | Query parameter. data Param @@ -233,6 +242,9 @@ addQueryParam :: Param -> Link -> Link addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } +addFragment :: Fragment' -> Link -> Link +addFragment fr l = l { _fragment = fr } + -- | Transform 'Link' into 'URI'. -- -- >>> type API = "something" :> Get '[JSON] Int @@ -250,7 +262,7 @@ addQueryParam qp l = -- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] () -- >>> let someRoute = Proxy :: Proxy SomeRoute -- >>> safeLink someRoute someRoute "test@example.com" --- Link {_segments = ["abc","test%40example.com"], _queryParams = []} +-- Link {_segments = ["abc","test%40example.com"], _queryParams = [], _fragment = Nothing} -- -- >>> linkURI $ safeLink someRoute someRoute "test@example.com" -- abc/test%40example.com @@ -274,11 +286,12 @@ data LinkArrayElementStyle -- sum?x=1&x=2&x=3 -- linkURI' :: LinkArrayElementStyle -> Link -> URI -linkURI' addBrackets (Link segments q_params) = +linkURI' addBrackets (Link segments q_params mfragment) = URI mempty -- No scheme (relative) Nothing -- Or authority (relative) (intercalate "/" $ map getEscaped segments) - (makeQueries q_params) mempty + (makeQueries q_params) + (makeFragment mfragment) where makeQueries :: [Param] -> String makeQueries [] = "" @@ -291,6 +304,10 @@ linkURI' addBrackets (Link segments q_params) = makeQuery (FlagParam k) = escape k makeQuery (FormParam f) = LBSC.unpack f + makeFragment :: Fragment' -> String + makeFragment Nothing = "" + makeFragment (Just fr) = "#" <> escape fr + style = case addBrackets of LinkArrayElementBracket -> "[]=" LinkArrayElementPlain -> "=" @@ -316,7 +333,7 @@ safeLink' -> Proxy api -- ^ The whole API that this endpoint is a part of -> Proxy endpoint -- ^ The API endpoint you would like to point to -> MkLink endpoint a -safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty) +safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty mempty) -- | Create all links in an API. -- @@ -347,7 +364,7 @@ allLinks' => (Link -> a) -> Proxy api -> MkLink api a -allLinks' toA api = toLink toA api (Link mempty mempty) +allLinks' toA api = toLink toA api (Link mempty mempty mempty) ------------------------------------------------------------------------------- -- Generics @@ -574,12 +591,24 @@ instance HasLink (Stream m status fr ct a) where type MkLink (Stream m status fr ct a) r = r toLink toA _ = toA +-- UVerb instances +instance HasLink (UVerb m ct a) where + type MkLink (UVerb m ct a) r = r + toLink toA _ = toA + -- AuthProtext instances instance HasLink sub => HasLink (AuthProtect tag :> sub) where type MkLink (AuthProtect tag :> sub) a = MkLink sub a toLink = simpleToLink (Proxy :: Proxy sub) --- | Helper for implemneting 'toLink' for combinators not affecting link +instance (HasLink sub, ToHttpApiData v) + => HasLink (Fragment v :> sub) where + type MkLink (Fragment v :> sub) a = v -> MkLink sub a + toLink toA _ l mv = + toLink toA (Proxy :: Proxy sub) $ + addFragment ((Just . Text.unpack . toQueryParam) mv) l + +-- | Helper for implementing 'toLink' for combinators not affecting link -- structure. simpleToLink :: forall sub a combinator. diff --git a/servant/src/Servant/Test/ComprehensiveAPI.hs b/servant/src/Servant/Test/ComprehensiveAPI.hs index 4445986a..67417869 100644 --- a/servant/src/Servant/Test/ComprehensiveAPI.hs +++ b/servant/src/Servant/Test/ComprehensiveAPI.hs @@ -48,7 +48,7 @@ comprehensiveAPIWithoutStreaming = Proxy type ComprehensiveAPIWithoutStreamingOrRaw' endpoint = GET :<|> "get-int" :> Get '[JSON] Int - :<|> "capture" :> Capture' '[Description "example description"] "foo" Int :> GET + :<|> "capture" :> Capture' '[Description "example description"] "bar" Int :> GET :<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET :<|> "header" :> Header "foo" Int :> GET :<|> "header-lenient" :> Header' '[Required, Lenient] "bar" Int :> GET @@ -71,6 +71,7 @@ type ComprehensiveAPIWithoutStreamingOrRaw' endpoint = :<|> "summary" :> Summary "foo" :> GET :<|> "description" :> Description "foo" :> GET :<|> "alternative" :> ("left" :> GET :<|> "right" :> GET) + :<|> "fragment" :> Fragment Int :> GET :<|> endpoint type ComprehensiveAPIWithoutStreamingOrRaw = ComprehensiveAPIWithoutStreamingOrRaw' EmptyEndpoint diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs deleted file mode 100644 index dc6d1b71..00000000 --- a/servant/src/Servant/Utils/Links.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Servant.Utils.Links - {-# DEPRECATED "Use Servant.Links." #-} - ( module Servant.Links ) - where - -import Servant.Links diff --git a/servant/test/Servant/API/StreamSpec.hs b/servant/test/Servant/API/StreamSpec.hs index 74eac52a..fc5c5046 100644 --- a/servant/test/Servant/API/StreamSpec.hs +++ b/servant/test/Servant/API/StreamSpec.hs @@ -90,7 +90,7 @@ runRenderFrames :: (SourceT Identity a -> SourceT Identity LBS.ByteString) -> [a runRenderFrames f = fmap mconcat . runExcept . runSourceT . f . source runUnrenderFrames :: (SourceT Identity b -> SourceT Identity a) -> [b] -> [Either String a] -runUnrenderFrames f = go . Effect . flip unSourceT return . f . source where +runUnrenderFrames f = go . Effect . (\x -> unSourceT x return) . f . source where go :: StepT Identity a -> [Either String a] go Stop = [] go (Error err) = [Left err] diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index 98450cc2..d1f0820e 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -15,13 +15,11 @@ import qualified Data.Text as T import GHC.Generics import Test.Hspec (Expectation, Spec, describe, it, shouldBe, shouldContain) -import Web.FormUrlEncoded - (ToForm(..)) import Servant.API +import Servant.Links import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw) -import Servant.Links type TestApi = -- Capture and query params @@ -34,6 +32,12 @@ type TestApi = -- Flags :<|> "balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent + -- Fragment + :<|> "say" :> Fragment String :> Get '[JSON] NoContent + + -- UVerb + :<|> "uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent] + -- All of the verbs :<|> "get" :> Get '[JSON] NoContent :<|> "put" :> Put '[JSON] NoContent @@ -111,12 +115,20 @@ spec = describe "Servant.Links" $ do ["roads", "lead", "to", "rome"] `shouldBeLink` "all/roads/lead/to/rome" + it "generated correct links for UVerbs" $ do + apiLink (Proxy :: Proxy ("uverb-example" :> UVerb 'GET '[JSON] '[WithStatus 200 NoContent])) + `shouldBeLink` "uverb-example" + it "generates correct links for query flags" $ do let l1 = Proxy :: Proxy ("balls" :> QueryFlag "bouncy" :> QueryFlag "fast" :> Delete '[JSON] NoContent) apiLink l1 True True `shouldBeLink` "balls?bouncy&fast" apiLink l1 False True `shouldBeLink` "balls?fast" + it "generates correct link for fragment" $ do + let l1 = Proxy :: Proxy ("say" :> Fragment String :> Get '[JSON] NoContent) + apiLink l1 "something" `shouldBeLink` "say#something" + it "generates correct links for all of the verbs" $ do apiLink (Proxy :: Proxy ("get" :> Get '[JSON] NoContent)) `shouldBeLink` "get" apiLink (Proxy :: Proxy ("put" :> Put '[JSON] NoContent)) `shouldBeLink` "put" diff --git a/stack.yaml b/stack.yaml index 491c55b1..8536a661 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-14.17 +resolver: lts-18.5 packages: - servant-client-core/ - servant-client/ diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 00000000..ce72109b --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,19 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + hackage: hspec-wai-0.10.1@sha256:56dd9ec1d56f47ef1946f71f7cbf070e4c285f718cac1b158400ae5e7172ef47,2290 + pantry-tree: + size: 809 + sha256: 17af1c2e709cd84bfda066b9ebb04cdde7f92660c51a1f7401a1e9f766524e93 + original: + hackage: hspec-wai-0.10.1 +snapshots: +- completed: + size: 585817 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/5.yaml + sha256: 22d24d0dacad9c1450b9a174c28d203f9bb482a2a8da9710a2f2a9f4afee2887 + original: lts-18.5