Compare commits
No commits in common. "master" and "0.0.0.0" have entirely different histories.
4
.gitignore
vendored
4
.gitignore
vendored
@ -1,6 +1,2 @@
|
|||||||
doc/_build/
|
doc/_build/
|
||||||
scripts/
|
scripts/
|
||||||
samples/
|
|
||||||
test-servers/
|
|
||||||
/doc/
|
|
||||||
.stack-work/
|
|
||||||
|
|||||||
186
.travis.yml
186
.travis.yml
@ -1,158 +1,34 @@
|
|||||||
# This Travis job script has been generated by a script via
|
sudo: false
|
||||||
#
|
|
||||||
# haskell-ci '--config=cabal.haskell-ci' 'servant-quickcheck.cabal'
|
|
||||||
#
|
|
||||||
# To regenerate the script (for example after adjusting tested-with) run
|
|
||||||
#
|
|
||||||
# haskell-ci regenerate
|
|
||||||
#
|
|
||||||
# For more information, see https://github.com/haskell-CI/haskell-ci
|
|
||||||
#
|
|
||||||
# version: 0.10.1
|
|
||||||
#
|
|
||||||
version: ~> 1.0
|
|
||||||
language: c
|
language: c
|
||||||
os: linux
|
|
||||||
dist: xenial
|
env:
|
||||||
git:
|
- GHCVER=7.8.4
|
||||||
# whether to recursively clone submodules
|
- GHCVER=7.10.2
|
||||||
submodules: false
|
|
||||||
branches:
|
addons:
|
||||||
only:
|
apt:
|
||||||
- master
|
sources:
|
||||||
|
- hvr-ghc
|
||||||
|
packages:
|
||||||
|
- ghc-7.8.4
|
||||||
|
- ghc-7.10.2
|
||||||
|
- cabal-install-1.22
|
||||||
|
- libgmp-dev
|
||||||
|
- wrk
|
||||||
|
|
||||||
|
install:
|
||||||
|
- (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
|
||||||
|
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
|
||||||
|
- ghc --version
|
||||||
|
- cabal --version
|
||||||
|
- travis_retry cabal update
|
||||||
|
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
|
||||||
|
|
||||||
|
script:
|
||||||
|
- tinc && cabal configure --enable-tests && cabal build && cabal test
|
||||||
|
#- (cd doc && tinc cabal configure --enable-tests && cabal build && cabal test)
|
||||||
|
|
||||||
cache:
|
cache:
|
||||||
directories:
|
directories:
|
||||||
- $HOME/.cabal/packages
|
- $HOME/.tinc/cache
|
||||||
- $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: ghc-8.8.3
|
|
||||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}}
|
|
||||||
os: linux
|
|
||||||
- compiler: ghc-8.6.5
|
|
||||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}}
|
|
||||||
os: linux
|
|
||||||
- compiler: ghc-8.4.4
|
|
||||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}}
|
|
||||||
os: linux
|
|
||||||
- compiler: ghc-8.2.2
|
|
||||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}}
|
|
||||||
os: linux
|
|
||||||
- compiler: ghc-8.0.2
|
|
||||||
addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}}
|
|
||||||
os: linux
|
|
||||||
before_install:
|
|
||||||
- HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
|
|
||||||
- WITHCOMPILER="-w $HC"
|
|
||||||
- HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
|
|
||||||
- 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
|
|
||||||
- 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
|
|
||||||
install:
|
|
||||||
- ${CABAL} --version
|
|
||||||
- echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
|
|
||||||
- |
|
|
||||||
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
|
|
||||||
# Generate cabal.project
|
|
||||||
- rm -rf cabal.project cabal.project.local cabal.project.freeze
|
|
||||||
- touch cabal.project
|
|
||||||
- |
|
|
||||||
echo "packages: ." >> cabal.project
|
|
||||||
- if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi
|
|
||||||
- "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
|
|
||||||
- |
|
|
||||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-quickcheck)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
|
||||||
- cat cabal.project || true
|
|
||||||
- cat cabal.project.local || true
|
|
||||||
- if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
|
|
||||||
- ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
|
|
||||||
- "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
|
|
||||||
- rm cabal.project.freeze
|
|
||||||
- travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all
|
|
||||||
- travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all
|
|
||||||
script:
|
|
||||||
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
|
|
||||||
# Packaging...
|
|
||||||
- ${CABAL} v2-sdist all
|
|
||||||
# Unpacking...
|
|
||||||
- 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_quickcheck="$(find . -maxdepth 1 -type d -regex '.*/servant-quickcheck-[0-9.]*')"
|
|
||||||
# Generate cabal.project
|
|
||||||
- rm -rf cabal.project cabal.project.local cabal.project.freeze
|
|
||||||
- touch cabal.project
|
|
||||||
- |
|
|
||||||
echo "packages: ${PKGDIR_servant_quickcheck}" >> cabal.project
|
|
||||||
- if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi
|
|
||||||
- "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
|
|
||||||
- |
|
|
||||||
- "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-quickcheck)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
|
|
||||||
- cat cabal.project || true
|
|
||||||
- cat cabal.project.local || true
|
|
||||||
# Building...
|
|
||||||
# this builds all libraries and executables (without tests/benchmarks)
|
|
||||||
- ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
|
|
||||||
# Building with tests and benchmarks...
|
|
||||||
# build & run tests, build benchmarks
|
|
||||||
- ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
|
|
||||||
# Testing...
|
|
||||||
- ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all
|
|
||||||
# cabal check...
|
|
||||||
- (cd ${PKGDIR_servant_quickcheck} && ${CABAL} -vnormal check)
|
|
||||||
# haddock...
|
|
||||||
- ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all
|
|
||||||
# Building without installed constraints for packages in global-db...
|
|
||||||
- rm -f cabal.project.local
|
|
||||||
- ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
|
|
||||||
# Constraint sets
|
|
||||||
- rm -rf cabal.project.local
|
|
||||||
# Constraint set base-compat-0.10
|
|
||||||
- ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.10.*' all
|
|
||||||
# Constraint set base-compat-0.11
|
|
||||||
- ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.11.*' all
|
|
||||||
|
|
||||||
# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","servant-quickcheck.cabal"])
|
|
||||||
# EOF
|
|
||||||
|
|||||||
214
CHANGELOG.yaml
214
CHANGELOG.yaml
@ -1,214 +0,0 @@
|
|||||||
releases:
|
|
||||||
- version: "0.0.9.0"
|
|
||||||
changes:
|
|
||||||
- description: "Support servant-0.15 (#65)"
|
|
||||||
authors: fizruk
|
|
||||||
date: 2020-06-25
|
|
||||||
|
|
||||||
- description: "Relax constraints for GHC 8.10 (#70)"
|
|
||||||
authors: felixmulder
|
|
||||||
date: 2020-06-20
|
|
||||||
|
|
||||||
- version: "0.0.8.0"
|
|
||||||
changes:
|
|
||||||
- description: Support for servant-0.17
|
|
||||||
authors: phadej
|
|
||||||
date: 2019-01-23
|
|
||||||
|
|
||||||
- version: "0.0.7.3"
|
|
||||||
changes:
|
|
||||||
- description: Support for servant-0.14
|
|
||||||
issue: 53
|
|
||||||
authors: phadej
|
|
||||||
date: 2018-06-12
|
|
||||||
|
|
||||||
- description: Fix a failure from OnlyJsonObjects when there is no content-type.
|
|
||||||
issue: 55
|
|
||||||
authors: Phenitei
|
|
||||||
date: 2018-08-27
|
|
||||||
|
|
||||||
- description: A bug fix where notAllowedContainsAllowHeader would print the initial request alongside the failure instead of the request causing the failure when it failed.
|
|
||||||
issue: 57
|
|
||||||
authors: Phenitei
|
|
||||||
date: 2018-08-29
|
|
||||||
|
|
||||||
- description: QuickCheck 2.12 compatibility
|
|
||||||
issue: 58
|
|
||||||
authors: parsonsmatt
|
|
||||||
date: 2018-10-12
|
|
||||||
|
|
||||||
- description: GHC 8.6 compatibility
|
|
||||||
issue: 59
|
|
||||||
authors: phadej
|
|
||||||
date: 2018-10-15
|
|
||||||
|
|
||||||
- version: "0.0.7.2"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Allow client to pass an HTTP Manager in to functions
|
|
||||||
issue: 47
|
|
||||||
authors: parsonsmatt
|
|
||||||
date: 2018-05-10
|
|
||||||
|
|
||||||
- description: Fix "should not happen" error when exceptions are thrown
|
|
||||||
issue: 48
|
|
||||||
authors: parsonsmatt
|
|
||||||
date: 2018-05-10
|
|
||||||
|
|
||||||
- version: "0.0.7.0"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Support for base-compat-0.10
|
|
||||||
issue: none
|
|
||||||
authors: phadej
|
|
||||||
date: 2018-04-12
|
|
||||||
|
|
||||||
- version: "0.0.7.0"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Support for GHC-8.4.1
|
|
||||||
issue: none
|
|
||||||
authors: phadej
|
|
||||||
date: 2018-03-23
|
|
||||||
|
|
||||||
- description: Requires hspec-2.5
|
|
||||||
issue: none
|
|
||||||
authors: phadej
|
|
||||||
date: 2018-03-23
|
|
||||||
|
|
||||||
- version: "0.0.6.0"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Support for servant-0.12
|
|
||||||
issue: none
|
|
||||||
authors: phadej
|
|
||||||
date: 2018-02-09
|
|
||||||
|
|
||||||
- version: "0.0.5.0"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Export forgotten predicates
|
|
||||||
issue: none
|
|
||||||
pr: 40
|
|
||||||
authors: Phenitei
|
|
||||||
date: 2017-12-14
|
|
||||||
|
|
||||||
- version: "0.0.4"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Support for Servant 0.12
|
|
||||||
issue: none
|
|
||||||
authors: phadej
|
|
||||||
date: 2017-11-07
|
|
||||||
|
|
||||||
- description: Support for Servant 0.11
|
|
||||||
issue: none
|
|
||||||
pr: 32
|
|
||||||
authors: adinapoli-iohk
|
|
||||||
date: 2017-10-18
|
|
||||||
notes: Includes 0-weighted instance for EmptyAPI
|
|
||||||
|
|
||||||
- version: "0.0.3.0"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Add jsonEquality
|
|
||||||
issue: 2
|
|
||||||
pr: 30
|
|
||||||
authors: erewok
|
|
||||||
date: 2017-10-15
|
|
||||||
|
|
||||||
- description: Support hspec >= 2.4
|
|
||||||
issue: 27
|
|
||||||
pr: 29
|
|
||||||
authors: erewok, jkarni
|
|
||||||
date: 2017-10-15
|
|
||||||
|
|
||||||
- version: "0.0.2.4"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Don't append slashes to paths
|
|
||||||
issue: 22
|
|
||||||
authors: declension
|
|
||||||
date: 2017-03-11
|
|
||||||
|
|
||||||
- version: "0.0.2.3"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Fix QueryParam and QueryFlag requests
|
|
||||||
issue: 23
|
|
||||||
authors: declension
|
|
||||||
date: 2017-03-10
|
|
||||||
|
|
||||||
- version: "0.0.2.2"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Make onlyJsonObjects succeed in non-JSON endpoints
|
|
||||||
issue: 20
|
|
||||||
authors: jkarni
|
|
||||||
date: 2016-10-18
|
|
||||||
|
|
||||||
|
|
||||||
- version: "0.0.2.1"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Add notLongerThan predicate
|
|
||||||
pr: 17
|
|
||||||
authors: jkarni
|
|
||||||
date: 2016-10-05
|
|
||||||
|
|
||||||
- description: Add getsHaveLastModifiedHeader predicate
|
|
||||||
pr: none
|
|
||||||
authors: jkarni
|
|
||||||
date: 2016-10-03
|
|
||||||
|
|
||||||
- description: Raise upper bounds
|
|
||||||
notes: >
|
|
||||||
For Quickcheck, aeson, http-client, servant, servant-client and
|
|
||||||
servant-server.
|
|
||||||
pr: none
|
|
||||||
authors: jkarni
|
|
||||||
date: 2016-10-03
|
|
||||||
|
|
||||||
|
|
||||||
- version: "0.0.2.0"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Update CHANGELOG to YAML syntax.
|
|
||||||
pr: 16
|
|
||||||
authors: jkarni
|
|
||||||
date: 2016-09-14
|
|
||||||
|
|
||||||
- description: Support new CaptureAll combinator
|
|
||||||
pr: 16
|
|
||||||
authors: jkarni
|
|
||||||
date: 2016-09-14
|
|
||||||
|
|
||||||
- description: Support GHC 8
|
|
||||||
pr: 16
|
|
||||||
authors: jkarni
|
|
||||||
date: 2016-09-14
|
|
||||||
|
|
||||||
- version: "0.0.1.1"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Exclude GHC 7.8 (by bumping base lower bound to 4.8)
|
|
||||||
pr: none
|
|
||||||
authors: jkarni
|
|
||||||
|
|
||||||
- description: More generous bounds for other packages.
|
|
||||||
pr: none
|
|
||||||
authors: jkarni
|
|
||||||
|
|
||||||
- version: "0.0.1.0"
|
|
||||||
changes:
|
|
||||||
|
|
||||||
- description: Better error messages.
|
|
||||||
notes: >
|
|
||||||
Error messages now contain failing predicate, failing response and
|
|
||||||
(except for response predicates), failing requests.
|
|
||||||
pr: none
|
|
||||||
authors: jkarni
|
|
||||||
|
|
||||||
- description: Signicant changes to RequestPredicate and ResponsePredicate types.
|
|
||||||
pr: none
|
|
||||||
authors: jkarni
|
|
||||||
@ -1,7 +0,0 @@
|
|||||||
branches: master
|
|
||||||
|
|
||||||
constraint-set base-compat-0.10
|
|
||||||
constraints: base-compat ==0.10.*
|
|
||||||
|
|
||||||
constraint-set base-compat-0.11
|
|
||||||
constraints: base-compat ==0.11.*
|
|
||||||
@ -1,4 +0,0 @@
|
|||||||
packages: .
|
|
||||||
tests: true
|
|
||||||
|
|
||||||
allow-newer: servant-blaze:servant
|
|
||||||
@ -10,62 +10,13 @@ an API description.
|
|||||||
|
|
||||||
This is much closer to the traditional use of `QuickCheck`. The most obvious
|
This is much closer to the traditional use of `QuickCheck`. The most obvious
|
||||||
use-case is checking that properties hold of an *entire* server rather than of
|
use-case is checking that properties hold of an *entire* server rather than of
|
||||||
individual endpoints. (But there are other uses that you can skip to if they
|
individual endpoints.
|
||||||
sound more interesting.)
|
|
||||||
|
|
||||||
## `serverSatisfies`
|
## `serverSatisfies`
|
||||||
|
|
||||||
A useful guideline when writing and maintaing software is that, if there isn't
|
There are a variety of best practices in writing web APIs that aren't always
|
||||||
a test for a behaviour or property, sooner or later that property will be broken.
|
obvious. As a running example, let's use a simple service that allows adding,
|
||||||
Another important perspective is that tests are a form of documentation - the
|
removing, and querying biological species. Our SQL schema is:
|
||||||
present developer telling future ones "this matters, and should be this way".
|
|
||||||
|
|
||||||
The advantage of using tests for this form of documentation is that there's
|
|
||||||
simply too much information to convey, some of it only relevant to very specific
|
|
||||||
use cases, and rather than overload developers with an inexhaustible quantity of
|
|
||||||
details that would be hard to keep track of or remember, tests are a mechanism
|
|
||||||
of reminding developers of *only the relevant information, at the right time*.
|
|
||||||
<<EXAMPLE>>.
|
|
||||||
|
|
||||||
We might hope that we could use tests to communicate the wide array of best
|
|
||||||
practices that have developed around APIs. About to return a top-level integer
|
|
||||||
in JSON? A test should say that's bad practice. About to not catch exceptions
|
|
||||||
and give a more meaningful HTTP status code? Another test there to stop you.
|
|
||||||
|
|
||||||
Traditionally, in web services these things get done at the level of *individual*
|
|
||||||
endpoints. But this means that if a developer who hasn't had extensive experience with web
|
|
||||||
programming best practices writes a *new* endpoint which *does* return a top-level
|
|
||||||
integer literal, there's no test there to stop her. Code review might help, but
|
|
||||||
code review is much more error prone than tests, and really only meant for those
|
|
||||||
things that are too subtle to automate. (Indeed, if code review were such a reliable
|
|
||||||
defense mechanism against bugs and bad code, why have tests and linters at all?)
|
|
||||||
|
|
||||||
The problem, then, with thinking about tests as only existing at the level of individual
|
|
||||||
endpoints is that there are no tests *for* tests - tests that check that new
|
|
||||||
behaviour and tests conforms to higher-level, more general best practices.
|
|
||||||
|
|
||||||
`servant-quickcheck` aims to solve that. It allows describing properties that
|
|
||||||
*all* endpoints must satisfy. If a new endpoint comes along, it too will be
|
|
||||||
tested for that property, without any further work.
|
|
||||||
|
|
||||||
Why isn't this idea already popular? Well, most web frameworks don't have a
|
|
||||||
reified description of APIs (beyond perhaps the routes). When you don't know
|
|
||||||
what the endpoints of an application are, and what request body they expect,
|
|
||||||
trying to generate arbitrary requests is almost entirely going to result in
|
|
||||||
404s (not found) and 400s (bad request). Maybe one in a thousand requests will
|
|
||||||
actually test a handler. Not very useful.
|
|
||||||
|
|
||||||
`servant` applications, on the other hand, have a machine-readable API description
|
|
||||||
already available. And they already associate "correct" requests with particular
|
|
||||||
types. It's a small step, therefore, to generate 'arbitrary' values for these
|
|
||||||
requests, and all of them will go through to your handlers. (Note: all of the
|
|
||||||
uses of `servant-quickcheck` work with applications *not* written with servant-server -
|
|
||||||
and indeed not *in Haskell - but the API must be described with the servant
|
|
||||||
DSL.)
|
|
||||||
|
|
||||||
Let's see how this works in practice. As a running example, let's use a simple
|
|
||||||
service that allows adding, removing, and querying biological species. Our SQL
|
|
||||||
schema is:
|
|
||||||
|
|
||||||
:d schema.sql
|
:d schema.sql
|
||||||
|
|
||||||
@ -102,8 +53,9 @@ import Control.Monad.IO.Class (liftIO)
|
|||||||
type API
|
type API
|
||||||
= "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
|
= "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
|
||||||
:<|> Delete '[JSON] ())
|
:<|> Delete '[JSON] ())
|
||||||
:<|> ReqBody '[JSON] Species :> Post '[JSON] ()
|
:<|> ReqBody '[JSON] Species :> Post '[JSON] ())
|
||||||
:<|> Get '[JSON] [Species])
|
-- The plural of 'species' is unfortunately also 'species'
|
||||||
|
:<|> "speciess" :> Get '[JSON] [Species]
|
||||||
|
|
||||||
api :: Proxy API
|
api :: Proxy API
|
||||||
api = Proxy
|
api = Proxy
|
||||||
@ -164,8 +116,6 @@ If you want to run this example.)
|
|||||||
This is a plausible effort. You might want to spend a moment thinking about what
|
This is a plausible effort. You might want to spend a moment thinking about what
|
||||||
could be improved.
|
could be improved.
|
||||||
|
|
||||||
Here are some `servant-quickcheck`-based tests for this API:
|
|
||||||
|
|
||||||
:d Spec.hs
|
:d Spec.hs
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
@ -179,12 +129,11 @@ import Test.QuickCheck (Arbitrary(..))
|
|||||||
import Database.PostgreSQL.Simple (connectPostgreSQL)
|
import Database.PostgreSQL.Simple (connectPostgreSQL)
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = describe "the species application" $ beforeAll check $ do
|
spec = describe "the species application" $ do
|
||||||
let pserver = do
|
let pserver = do
|
||||||
conn <- connectPostgreSQL "dbname=servant-quickcheck"
|
conn <- connectPostgreSQL "dbname=servant-quickcheck"
|
||||||
return $ server conn
|
return $ server conn
|
||||||
|
|
||||||
|
|
||||||
it "should not return 500s" $ do
|
it "should not return 500s" $ do
|
||||||
withServantServer api pserver $ \url ->
|
withServantServer api pserver $ \url ->
|
||||||
serverSatisfies api url defaultArgs (not500 <%> mempty)
|
serverSatisfies api url defaultArgs (not500 <%> mempty)
|
||||||
@ -193,30 +142,6 @@ spec = describe "the species application" $ beforeAll check $ do
|
|||||||
withServantServer api pserver $ \url ->
|
withServantServer api pserver $ \url ->
|
||||||
serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
|
serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
|
||||||
|
|
||||||
it "should return valid locations for 201" $ do
|
|
||||||
withServantServer api pserver $ \url ->
|
|
||||||
serverSatisfies api url defaultArgs (createContainsValidLocation <%> mempty)
|
|
||||||
|
|
||||||
it "honours Accept header" $ do
|
|
||||||
withServantServer api pserver $ \url ->
|
|
||||||
serverSatisfies api url defaultArgs (honoursAcceptHeader <%> mempty)
|
|
||||||
|
|
||||||
it "405s contain Allow header" $ do
|
|
||||||
withServantServer api pserver $ \url ->
|
|
||||||
serverSatisfies api url defaultArgs (notAllowedContainsValidAllow <%> mempty)
|
|
||||||
|
|
||||||
it "should contain WWW-Authenticate header when returning 401s" $ do
|
|
||||||
withServantServer api pserver $ \url ->
|
|
||||||
serverSatisfies api url defaultArgs (unauthorizedContainsWWWAuthenticate <%> mempty)
|
|
||||||
|
|
||||||
it "GETs should have Cache-Control header" $ do
|
|
||||||
withServantServer api pserver $ \url ->
|
|
||||||
serverSatisfies api url defaultArgs (getsHaveCacheControlHeader <%> mempty)
|
|
||||||
|
|
||||||
it "HEADs should have Cache-Control header" $ do
|
|
||||||
withServantServer api pserver $ \url ->
|
|
||||||
serverSatisfies api url defaultArgs (headsHaveCacheControlHeader <%> mempty)
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
hspec spec
|
hspec spec
|
||||||
@ -226,94 +151,6 @@ instance Arbitrary Species where
|
|||||||
:
|
:
|
||||||
|
|
||||||
|
|
||||||
I won't go through all of the failures; as this is a literate haskell file, you
|
|
||||||
can go through them yourself if you're interested. But worth mentioning:
|
|
||||||
|
|
||||||
- The possible pattern match failure in `lookupSpecies` is caught.
|
|
||||||
- Returning a top-level list is caught.
|
|
||||||
- Not having a link for the `PostCreated` is caught.
|
|
||||||
|
|
||||||
This last test failure illustrates an important point.
|
|
||||||
|
|
||||||
|
|
||||||
This was an example created with the knowledge of what it was supposed to
|
|
||||||
exemplify. To try to get a more accurate assessment of the practical usefulness
|
|
||||||
of `servant-quickcheck`, I tried running `serverSatisfies` with a few
|
|
||||||
predicates over some of the open-source `servant` servers I could find, and
|
|
||||||
results were also promising.
|
|
||||||
|
|
||||||
There are probably a lot of other interesting properties that one might to add
|
|
||||||
besides those I've included. As an example, we could have a property that
|
|
||||||
all HTML is checked against, which is sometimes tricky for HTML that's
|
|
||||||
generated dynamically. Or check that every page has a Portuguese translation.
|
|
||||||
|
|
||||||
### Why best practices are good
|
|
||||||
|
|
||||||
As a side note: you might have wondered "why bother with API best practices?".
|
|
||||||
It is, it has to be said, a lot of extra (as in not only getting the feature done)
|
|
||||||
work to do, for dubious benefit. And indeed, the relevance of discoverability, for
|
|
||||||
example, unclear, since not that many tools use it as perhaps was anticipated.
|
|
||||||
|
|
||||||
But `servant-quickcheck` both makes it *easier* to conform to best practices,
|
|
||||||
and exemplifies their advantage in enabling better tooling. If we pick 201 (Success, the 'resource' was
|
|
||||||
created), rather than the more generic 200 (Success), and do a *little* more work
|
|
||||||
by knowing to make this decision, `servant-quickcheck` knows this means there
|
|
||||||
should be some representation of the resource created. So it knows to ask you
|
|
||||||
for a link to it (the RFC creators thought to ask for this). And if you do (again,
|
|
||||||
a little more work), `servant-quickcheck` will know to try to look at that
|
|
||||||
resource by following the link, checking that it's not broken, and maybe even
|
|
||||||
returns a response that equivalent to the original POST request). And then it
|
|
||||||
finds a real bug - your application allows species with '/' in their name to
|
|
||||||
be created, but not queried with a 'GET' for! This, I think, is already a win.
|
|
||||||
|
|
||||||
|
|
||||||
## `serversEqual`
|
|
||||||
|
|
||||||
There's another very appealing application of the ability to generate "sensible"
|
|
||||||
arbitrary requests. It's for testing that two applications are equal. We can generate arbitrary
|
|
||||||
requests, send them to both servers (in the same order), and check that the responses
|
|
||||||
are equivalent. (This was, incidentally, one of the first applications of
|
|
||||||
`servant-client`, albeit in a much more manual way, when we rewrote a microservice
|
|
||||||
originally in Python in Haskell.) Generally with rewrites, even if there's some
|
|
||||||
behaviour that isn't optimal, perhaps a lot of things already depend on that service
|
|
||||||
and make interace poorly with "improvements", so it makes sense to first mimick
|
|
||||||
*exactly* the original behaviour, and only then aim for improvements.
|
|
||||||
|
|
||||||
`servant-quickcheck` provides a single function, `serversEqual`, that attempts
|
|
||||||
to verify the equivalence of servers. Since some aspects of responses might not
|
|
||||||
be relevant (for example, whether the the `Server` header is the same, or whether
|
|
||||||
two JSON responses have the same formatting), it allows you to provide a custom
|
|
||||||
equivalence function. Other than that, you need only provide an API type and two
|
|
||||||
URLs for testing, and the rest `serversEqual` handles.
|
|
||||||
|
|
||||||
## Future directions: benchmarking
|
|
||||||
|
|
||||||
What else could benefit from tooling that can automatically generate sensible
|
|
||||||
(*vis-a-vis* a particular application's expectations) requests?
|
|
||||||
|
|
||||||
One area is extensive automatic benchmarking. Currently we use tools such as
|
|
||||||
`ab`, `wrk`, `httperf` in a very manual way - we pick a particular request that
|
|
||||||
we are interested in, and write a request that gets made thousands of times.
|
|
||||||
But now we can have a multiplicity of requests to benchmark with! This allows
|
|
||||||
*finding* slow endpoints, as well as (I would imagine, though I haven't actually
|
|
||||||
tried this yet) finding synchronization issues that make threads wait for too
|
|
||||||
long (such as waiting on an MVar that's not really needed), bad asymptotics
|
|
||||||
with respect to some other type of request.
|
|
||||||
|
|
||||||
(On this last point, imagine not having an index in a database for "people",
|
|
||||||
and having a tool that discovers that the latency on a search by first name
|
|
||||||
grows linearly with the number of POST requests to a *different* endpoint! We'd
|
|
||||||
need to do some work to do this well, possibly involving some machine
|
|
||||||
learning, but it's an interesting and probably useful idea.)
|
|
||||||
|
|
||||||
|
|
||||||
# Conclusion
|
|
||||||
|
|
||||||
I hope this library presents some useful functionality already, but I hope
|
|
||||||
you'll also think how it could be improved!
|
|
||||||
|
|
||||||
There'll be a few more packages in the comings weeks - check back soon!
|
|
||||||
|
|
||||||
**Note**: This post is an anansi literate file that generates multiple source
|
**Note**: This post is an anansi literate file that generates multiple source
|
||||||
files. They are:
|
files. They are:
|
||||||
|
|
||||||
|
|||||||
@ -4,15 +4,12 @@ src/$(FILES): Announcement.anansi
|
|||||||
anansi tangle -o "src" Announcement.anansi
|
anansi tangle -o "src" Announcement.anansi
|
||||||
|
|
||||||
announcement.md: Announcement.anansi
|
announcement.md: Announcement.anansi
|
||||||
anansi weave -o "announcement.tmp" Announcement.anansi
|
anansi weave -o "announcement.md" Announcement.anansi
|
||||||
cat announcement.tmp | tr -d '«' | tr -d '»' > announcement.md
|
|
||||||
rm announcement.tmp
|
|
||||||
|
|
||||||
.stack-work/bin/posts: $(FILES) stack.yaml posts.cabal
|
.stack-work/bin/posts: $(FILES) stack.yaml posts.cabal
|
||||||
stack build
|
stack build
|
||||||
|
|
||||||
announcement.html: announcement.md
|
|
||||||
pandoc announcement.md -t html > announcement.html
|
|
||||||
|
|
||||||
run: .stack-work/bin/posts
|
run: .stack-work/bin/posts
|
||||||
stack exec posts
|
stack exec posts
|
||||||
@ -20,6 +17,6 @@ run: .stack-work/bin/posts
|
|||||||
test: .stack-work/bin/posts
|
test: .stack-work/bin/posts
|
||||||
stack test
|
stack test
|
||||||
|
|
||||||
post: announcement.html
|
post: announcement.md
|
||||||
|
|
||||||
.PHONY: post run test
|
.PHONY: post run test
|
||||||
|
|||||||
@ -9,71 +9,22 @@ an API description.
|
|||||||
|
|
||||||
This is much closer to the traditional use of `QuickCheck`. The most obvious
|
This is much closer to the traditional use of `QuickCheck`. The most obvious
|
||||||
use-case is checking that properties hold of an *entire* server rather than of
|
use-case is checking that properties hold of an *entire* server rather than of
|
||||||
individual endpoints. (But there are other uses that you can skip to if they
|
individual endpoints.
|
||||||
sound more interesting.)
|
|
||||||
|
|
||||||
## `serverSatisfies`
|
## `serverSatisfies`
|
||||||
|
|
||||||
A useful guideline when writing and maintaing software is that, if there isn't
|
There are a variety of best practices in writing web APIs that aren't always
|
||||||
a test for a behaviour or property, sooner or later that property will be broken.
|
obvious. As a running example, let's use a simple service that allows adding,
|
||||||
Another important perspective is that tests are a form of documentation - the
|
removing, and querying biological species. Our SQL schema is:
|
||||||
present developer telling future ones "this matters, and should be this way".
|
|
||||||
|
|
||||||
The advantage of using tests for this form of documentation is that there's
|
|
||||||
simply too much information to convey, some of it only relevant to very specific
|
|
||||||
use cases, and rather than overload developers with an inexhaustible quantity of
|
|
||||||
details that would be hard to keep track of or remember, tests are a mechanism
|
|
||||||
of reminding developers of *only the relevant information, at the right time*.
|
|
||||||
<<EXAMPLE>>.
|
|
||||||
|
|
||||||
We might hope that we could use tests to communicate the wide array of best
|
|
||||||
practices that have developed around APIs. About to return a top-level integer
|
|
||||||
in JSON? A test should say that's bad practice. About to not catch exceptions
|
|
||||||
and give a more meaningful HTTP status code? Another test there to stop you.
|
|
||||||
|
|
||||||
Traditionally, in web services these things get done at the level of *individual*
|
|
||||||
endpoints. But this means that if a developer who hasn't had extensive experience with web
|
|
||||||
programming best practices writes a *new* endpoint which *does* return a top-level
|
|
||||||
integer literal, there's no test there to stop her. Code review might help, but
|
|
||||||
code review is much more error prone than tests, and really only meant for those
|
|
||||||
things that are too subtle to automate. (Indeed, if code review were such a reliable
|
|
||||||
defense mechanism against bugs and bad code, why have tests and linters at all?)
|
|
||||||
|
|
||||||
The problem, then, with thinking about tests as only existing at the level of individual
|
|
||||||
endpoints is that there are no tests *for* tests - tests that check that new
|
|
||||||
behaviour and tests conforms to higher-level, more general best practices.
|
|
||||||
|
|
||||||
`servant-quickcheck` aims to solve that. It allows describing properties that
|
|
||||||
*all* endpoints must satisfy. If a new endpoint comes along, it too will be
|
|
||||||
tested for that property, without any further work.
|
|
||||||
|
|
||||||
Why isn't this idea already popular? Well, most web frameworks don't have a
|
|
||||||
reified description of APIs (beyond perhaps the routes). When you don't know
|
|
||||||
what the endpoints of an application are, and what request body they expect,
|
|
||||||
trying to generate arbitrary requests is almost entirely going to result in
|
|
||||||
404s (not found) and 400s (bad request). Maybe one in a thousand requests will
|
|
||||||
actually test a handler. Not very useful.
|
|
||||||
|
|
||||||
`servant` applications, on the other hand, have a machine-readable API description
|
|
||||||
already available. And they already associate "correct" requests with particular
|
|
||||||
types. It's a small step, therefore, to generate 'arbitrary' values for these
|
|
||||||
requests, and all of them will go through to your handlers. (Note: all of the
|
|
||||||
uses of `servant-quickcheck` work with applications *not* written with servant-server -
|
|
||||||
and indeed not *in Haskell - but the API must be described with the servant
|
|
||||||
DSL.)
|
|
||||||
|
|
||||||
Let's see how this works in practice. As a running example, let's use a simple
|
|
||||||
service that allows adding, removing, and querying biological species. Our SQL
|
|
||||||
schema is:
|
|
||||||
|
|
||||||
|
|
||||||
> **schema.sql**
|
> **«schema.sql»**
|
||||||
|
|
||||||
>
|
>
|
||||||
> CREATE TABLE genus (
|
> CREATE TABLE genus (
|
||||||
> genus_name text PRIMARY KEY,
|
> genus_name text PRIMARY KEY,
|
||||||
> genus_family text NOT NULL
|
> genus_family text NOT NULL
|
||||||
> );
|
> )
|
||||||
>
|
>
|
||||||
> CREATE TABLE species (
|
> CREATE TABLE species (
|
||||||
> species_name text PRIMARY KEY,
|
> species_name text PRIMARY KEY,
|
||||||
@ -84,7 +35,7 @@ schema is:
|
|||||||
And our actual application:
|
And our actual application:
|
||||||
|
|
||||||
|
|
||||||
> **Main.hs**
|
> **«Main.hs»**
|
||||||
|
|
||||||
> {-# LANGUAGE DataKinds #-}
|
> {-# LANGUAGE DataKinds #-}
|
||||||
> {-# LANGUAGE DeriveAnyClass #-}
|
> {-# LANGUAGE DeriveAnyClass #-}
|
||||||
@ -92,8 +43,6 @@ And our actual application:
|
|||||||
> {-# LANGUAGE TypeOperators #-}
|
> {-# LANGUAGE TypeOperators #-}
|
||||||
> {-# LANGUAGE OverloadedStrings #-}
|
> {-# LANGUAGE OverloadedStrings #-}
|
||||||
> {-# LANGUAGE RecordWildCards #-}
|
> {-# LANGUAGE RecordWildCards #-}
|
||||||
> module Main where
|
|
||||||
>
|
|
||||||
> import Servant
|
> import Servant
|
||||||
> import Data.Aeson
|
> import Data.Aeson
|
||||||
> import Database.PostgreSQL.Simple
|
> import Database.PostgreSQL.Simple
|
||||||
@ -105,9 +54,8 @@ And our actual application:
|
|||||||
> type API
|
> type API
|
||||||
> = "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
|
> = "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
|
||||||
> :<|> Delete '[JSON] ())
|
> :<|> Delete '[JSON] ())
|
||||||
> :<|> ReqBody '[JSON] Species :> Post '[JSON] ())
|
> :<|> ReqBody '[JSON] Species :> Post '[JSON] ()
|
||||||
> -- The plural of 'species' is unfortunately also 'species'
|
> :<|> "count" :> Get '[JSON] Int)
|
||||||
> :<|> "speciess" :> Get '[JSON] [Species]
|
|
||||||
>
|
>
|
||||||
> api :: Proxy API
|
> api :: Proxy API
|
||||||
> api = Proxy
|
> api = Proxy
|
||||||
@ -126,19 +74,19 @@ And our actual application:
|
|||||||
> instance FromRow Species
|
> instance FromRow Species
|
||||||
>
|
>
|
||||||
> server :: Connection -> Server API
|
> server :: Connection -> Server API
|
||||||
> server conn = ((\sname -> liftIO (lookupSpecies conn sname)
|
> server conn = (\sname -> liftIO (lookupSpecies conn sname)
|
||||||
> :<|> liftIO (deleteSpecies conn sname))
|
> :<|> liftIO (deleteSpecies conn sname))
|
||||||
> :<|> (\species -> liftIO $ insertSpecies conn species))
|
> :<|> (\species -> liftIO $ insertSpecies conn species)
|
||||||
> :<|> (liftIO $ allSpecies conn)
|
> :<|> (liftIO $ countSpecies conn)
|
||||||
>
|
>
|
||||||
> lookupSpecies :: Connection -> Text -> IO Species
|
> lookupSpecies :: Connection -> Text -> IO Species
|
||||||
> lookupSpecies conn name = do
|
> lookupSpecies conn name = do
|
||||||
> [s] <- query conn "SELECT * FROM species WHERE species_name = ?" (Only name)
|
> [s] <- query conn "SELECT * FROM species WHERE species_name == ?" (Only name)
|
||||||
> return s
|
> return s
|
||||||
>
|
>
|
||||||
> deleteSpecies :: Connection -> Text -> IO ()
|
> deleteSpecies :: Connection -> Text -> IO ()
|
||||||
> deleteSpecies conn name = do
|
> deleteSpecies conn name = do
|
||||||
> _ <- execute conn "DELETE FROM species WHERE species_name = ?" (Only name)
|
> _ <- execute conn "DELETE FROM species WHERE species_name == ?" (Only name)
|
||||||
> return ()
|
> return ()
|
||||||
>
|
>
|
||||||
> insertSpecies :: Connection -> Species -> IO ()
|
> insertSpecies :: Connection -> Species -> IO ()
|
||||||
@ -146,173 +94,25 @@ And our actual application:
|
|||||||
> _ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
|
> _ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
|
||||||
> return ()
|
> return ()
|
||||||
>
|
>
|
||||||
> allSpecies :: Connection -> IO [Species]
|
> countSpecies :: Connection -> IO Int
|
||||||
> allSpecies conn = do
|
> countSpecies conn = do
|
||||||
> query_ conn "SELECT * FROM species"
|
> [Only count] <- query_ conn "SELECT count(*) FROM species"
|
||||||
|
> return count
|
||||||
>
|
>
|
||||||
> main :: IO ()
|
> main :: IO ()
|
||||||
> main = do
|
> main = do
|
||||||
> conn <- connectPostgreSQL "dbname=servant-quickcheck"
|
> conn <- connectPostgreSQL ""
|
||||||
> run 8090 (serve api $ server conn)
|
> run 8090 (serve api $ server conn)
|
||||||
|
|
||||||
|
|
||||||
(You'll also also need to run:
|
|
||||||
|
|
||||||
```
|
> **» Main.hs**
|
||||||
createdb servant-quickcheck
|
|
||||||
psql --file schema.sql -d servant-quickcheck
|
|
||||||
```
|
|
||||||
|
|
||||||
If you want to run this example.)
|
> «Main.hs»
|
||||||
|
|
||||||
This is a plausible effort. You might want to spend a moment thinking about what
|
|
||||||
could be improved.
|
|
||||||
|
|
||||||
|
|
||||||
> **Spec.hs**
|
|
||||||
|
|
||||||
>
|
|
||||||
> {-# LANGUAGE OverloadedStrings #-}
|
|
||||||
> module Spec (main) where
|
|
||||||
>
|
|
||||||
> import Main (server, api, Species(..))
|
|
||||||
> import Test.Hspec
|
|
||||||
> import Test.QuickCheck.Instances
|
|
||||||
> import Servant.QuickCheck
|
|
||||||
> import Test.QuickCheck (Arbitrary(..))
|
|
||||||
> import Database.PostgreSQL.Simple (connectPostgreSQL)
|
|
||||||
>
|
|
||||||
> spec :: Spec
|
|
||||||
> spec = describe "the species application" $ beforeAll check $ do
|
|
||||||
> let pserver = do
|
|
||||||
> conn <- connectPostgreSQL "dbname=servant-quickcheck"
|
|
||||||
> return $ server conn
|
|
||||||
>
|
|
||||||
>
|
|
||||||
> it "should not return 500s" $ do
|
|
||||||
>
|
|
||||||
> it "should not return 500s" $ do
|
|
||||||
> withServantServer api pserver $ \url ->
|
|
||||||
> serverSatisfies api url defaultArgs (not500 <%> mempty)
|
|
||||||
>
|
|
||||||
> it "should not return top-level json" $ do
|
|
||||||
> withServantServer api pserver $ \url ->
|
|
||||||
> serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
|
|
||||||
>
|
|
||||||
> where
|
|
||||||
> check = do
|
|
||||||
> mvar <- newMVar []
|
|
||||||
> withServantServer api pserver $ \url ->
|
|
||||||
> serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
|
|
||||||
>
|
|
||||||
> main :: IO ()
|
|
||||||
> main = do
|
|
||||||
> hspec spec
|
|
||||||
>
|
|
||||||
> instance Arbitrary Species where
|
|
||||||
> arbitrary = Species <$> arbitrary <*> arbitrary
|
|
||||||
|
|
||||||
|
|
||||||
But this fails in quite a few ways.
|
|
||||||
|
|
||||||
|
|
||||||
<<TODO>>
|
|
||||||
|
|
||||||
This was an example created with the knowledge of what it was supposed to
|
|
||||||
exemplify. To try to get a more accurate assessment of the practical usefulness
|
|
||||||
of `servant-quickcheck`, I tried running `serverSatisfies` with a few
|
|
||||||
predicates over some of the open-source `servant` servers I could find, and
|
|
||||||
results were also promising.
|
|
||||||
|
|
||||||
There are probably a lot of other interesting properties that one might to add
|
|
||||||
besides those I've included. As an example, we could have a property that
|
|
||||||
all HTML is checked against, which is sometimes tricky for HTML that's
|
|
||||||
generated dynamically. Or check that every page has a Portuguese translation.
|
|
||||||
|
|
||||||
### Why best practices are good
|
|
||||||
|
|
||||||
As a side note: you might have wondered "why bother with API best practices?".
|
|
||||||
It is, it has to be said, a lot of extra (as in not only getting the feature done)
|
|
||||||
work to do, for dubious benefit. And indeed, the relevance of discoverability, for
|
|
||||||
example, unclear, since not that many tools use it as perhaps was anticipated.
|
|
||||||
|
|
||||||
But `servant-quickcheck` both makes it *easier* to conform to best practices,
|
|
||||||
and exemplifies their advantage in enabling better tooling. If we pick 201 (Success, the 'resource' was
|
|
||||||
created), rather than the more generic 200 (Success), and do a *little* more work
|
|
||||||
by knowing to make this decision, `servant-quickcheck` knows this means there
|
|
||||||
should be some representation of the resource created. So it knows to ask you
|
|
||||||
for a link to it (the RFC creators thought to ask for this). And if you do (again,
|
|
||||||
a little more work), `servant-quickcheck` will know to try to look at that
|
|
||||||
resource by following the link, checking that it's not broken, and maybe even
|
|
||||||
returns a response that equivalent to the original POST request). And then it
|
|
||||||
finds a real bug - your application allows species with '/' in their name to
|
|
||||||
be created, but not queried with a 'GET' for! This, I think, is already a win.
|
|
||||||
|
|
||||||
|
|
||||||
## `serversEqual`
|
|
||||||
|
|
||||||
There's another very appealing application of the ability to generate "sensible"
|
|
||||||
arbitrary requests. It's for testing that two applications are equal. We can generate arbitrary
|
|
||||||
requests, send them to both servers (in the same order), and check that the responses
|
|
||||||
are equivalent. (This was, incidentally, one of the first applications of
|
|
||||||
`servant-client`, albeit in a much more manual way, when we rewrote a microservice
|
|
||||||
originally in Python in Haskell.) Generally with rewrites, even if there's some
|
|
||||||
behaviour that isn't optimal, perhaps a lot of things already depend on that service
|
|
||||||
and make interace poorly with "improvements", so it makes sense to first mimick
|
|
||||||
*exactly* the original behaviour, and only then aim for improvements.
|
|
||||||
|
|
||||||
`servant-quickcheck` provides a single function, `serversEqual`, that attempts
|
|
||||||
to verify the equivalence of servers. Since some aspects of responses might not
|
|
||||||
be relevant (for example, whether the the `Server` header is the same, or whether
|
|
||||||
two JSON responses have the same formatting), it allows you to provide a custom
|
|
||||||
equivalence function. Other than that, you need only provide an API type and two
|
|
||||||
URLs for testing, and the rest `serversEqual` handles.
|
|
||||||
|
|
||||||
## Future directions: benchmarking
|
|
||||||
|
|
||||||
What else could benefit from tooling that can automatically generate sensible
|
|
||||||
(*vis-a-vis* a particular application's expectations) requests?
|
|
||||||
|
|
||||||
One area is extensive automatic benchmarking. Currently we use tools such as
|
|
||||||
`ab`, `wrk`, `httperf` in a very manual way - we pick a particular request that
|
|
||||||
we are interested in, and write a request that gets made thousands of times.
|
|
||||||
But now we can have a multiplicity of requests to benchmark with! This allows
|
|
||||||
*finding* slow endpoints, as well as (I would imagine, though I haven't actually
|
|
||||||
tried this yet) finding synchronization issues that make threads wait for too
|
|
||||||
long (such as waiting on an MVar that's not really needed), bad asymptotics
|
|
||||||
with respect to some other type of request.
|
|
||||||
|
|
||||||
(On this last point, imagine not having an index in a database for "people",
|
|
||||||
and having a tool that discovers that the latency on a search by first name
|
|
||||||
grows linearly with the number of POST requests to a *different* endpoint! We'd
|
|
||||||
need to do some work to do this well, possibly involving some machine
|
|
||||||
learning, but it's an interesting and probably useful idea.)
|
|
||||||
|
|
||||||
|
|
||||||
# Conclusion
|
|
||||||
|
|
||||||
I hope this library presents some useful functionality already, but I hope
|
|
||||||
you'll also think how it could be improved!
|
|
||||||
|
|
||||||
There'll be a few more packages in the comings weeks - check back soon!
|
|
||||||
|
|
||||||
**Note**: This post is an anansi literate file that generates multiple source
|
|
||||||
files. They are:
|
|
||||||
|
|
||||||
|
|
||||||
> ** Main.hs**
|
|
||||||
|
|
||||||
> Main.hs
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
> ** schema.sql**
|
> **» schema.sql**
|
||||||
|
|
||||||
> schema.sql
|
> «schema.sql»
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
> ** Spec.hs**
|
|
||||||
|
|
||||||
> Spec.hs
|
|
||||||
|
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
#line 296 "Announcement.anansi"
|
#line 158 "Announcement.anansi"
|
||||||
|
|
||||||
#line 86 "Announcement.anansi"
|
#line 37 "Announcement.anansi"
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE DeriveAnyClass #-}
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
{-# LANGUAGE DeriveGeneric #-}
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
#line 304 "Announcement.anansi"
|
#line 166 "Announcement.anansi"
|
||||||
|
|
||||||
#line 171 "Announcement.anansi"
|
#line 120 "Announcement.anansi"
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Spec (main) where
|
module Spec (main) where
|
||||||
@ -13,12 +13,11 @@ import Test.QuickCheck (Arbitrary(..))
|
|||||||
import Database.PostgreSQL.Simple (connectPostgreSQL)
|
import Database.PostgreSQL.Simple (connectPostgreSQL)
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = describe "the species application" $ beforeAll check $ do
|
spec = describe "the species application" $ do
|
||||||
let pserver = do
|
let pserver = do
|
||||||
conn <- connectPostgreSQL "dbname=servant-quickcheck"
|
conn <- connectPostgreSQL "dbname=servant-quickcheck"
|
||||||
return $ server conn
|
return $ server conn
|
||||||
|
|
||||||
|
|
||||||
it "should not return 500s" $ do
|
it "should not return 500s" $ do
|
||||||
withServantServer api pserver $ \url ->
|
withServantServer api pserver $ \url ->
|
||||||
serverSatisfies api url defaultArgs (not500 <%> mempty)
|
serverSatisfies api url defaultArgs (not500 <%> mempty)
|
||||||
@ -27,11 +26,6 @@ spec = describe "the species application" $ beforeAll check $ do
|
|||||||
withServantServer api pserver $ \url ->
|
withServantServer api pserver $ \url ->
|
||||||
serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
|
serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
|
||||||
|
|
||||||
it "should return valid locations for 201" $ do
|
|
||||||
withServantServer api pserver $ \url ->
|
|
||||||
serverSatisfies api url defaultArgs (createContainsValidLocation <%> mempty)
|
|
||||||
|
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
hspec spec
|
hspec spec
|
||||||
|
|||||||
@ -1,31 +0,0 @@
|
|||||||
{-# LANGUAGE OverloadedStrings, DataKinds #-}
|
|
||||||
module Main (main) where
|
|
||||||
|
|
||||||
import Servant
|
|
||||||
import Servant.QuickCheck
|
|
||||||
import Test.Hspec
|
|
||||||
import Data.Text (Text)
|
|
||||||
import System.Environment (getArgs)
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
args <- getArgs
|
|
||||||
case args of
|
|
||||||
[] -> putStrLn "Not running without arguments. Try --help or --fail-fast."
|
|
||||||
_ -> hspec spec
|
|
||||||
|
|
||||||
-- Change to String to reproduce
|
|
||||||
-- https://github.com/haskell-servant/servant-quickcheck/issues/41
|
|
||||||
type API = Get '[PlainText] Text
|
|
||||||
|
|
||||||
api :: Proxy API
|
|
||||||
api = Proxy
|
|
||||||
|
|
||||||
server :: Server API
|
|
||||||
server = return "Sigurð Fáfnirslayer"
|
|
||||||
|
|
||||||
spec :: Spec
|
|
||||||
spec = describe "example server" $
|
|
||||||
it "mangles UTF-8 in error messages" $
|
|
||||||
withServantServer api (return server) $ \burl ->
|
|
||||||
serverSatisfies api burl defaultArgs (getsHaveCacheControlHeader <%> mempty)
|
|
||||||
@ -1,138 +1,94 @@
|
|||||||
name: servant-quickcheck
|
name: servant-quickcheck
|
||||||
version: 0.0.9.1
|
version: 0.0.0.0
|
||||||
synopsis: QuickCheck entire APIs
|
synopsis: QuickCheck entire APIs
|
||||||
description:
|
description:
|
||||||
This packages provides QuickCheck properties that are tested across an entire
|
This packages provides QuickCheck properties that are tested across an entire
|
||||||
API.
|
API.
|
||||||
|
|
||||||
license: BSD3
|
license: BSD3
|
||||||
license-file: LICENSE
|
license-file: LICENSE
|
||||||
author: Julian K. Arni
|
author: Julian K. Arni
|
||||||
maintainer: jkarni@gmail.com
|
maintainer: jkarni@gmail.com
|
||||||
category: Web
|
category: Web
|
||||||
build-type: Simple
|
build-type: Simple
|
||||||
cabal-version: >=1.10
|
cabal-version: >=1.10
|
||||||
extra-source-files: CHANGELOG.yaml
|
|
||||||
tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3
|
|
||||||
|
|
||||||
source-repository head
|
|
||||||
type: git
|
|
||||||
location: https://github.com/haskell-servant/servant-quickcheck
|
|
||||||
|
|
||||||
flag long-tests
|
flag long-tests
|
||||||
description: Run more QuickCheck tests
|
description: Run more QuickCheck tests
|
||||||
default: False
|
default: False
|
||||||
|
|
||||||
library
|
library
|
||||||
exposed-modules:
|
exposed-modules: Servant.QuickCheck
|
||||||
Servant.QuickCheck
|
, Servant.QuickCheck.Internal
|
||||||
Servant.QuickCheck.Internal
|
, Servant.QuickCheck.Internal.Predicates
|
||||||
Servant.QuickCheck.Internal.Equality
|
, Servant.QuickCheck.Internal.HasGenRequest
|
||||||
Servant.QuickCheck.Internal.ErrorTypes
|
, Servant.QuickCheck.Internal.QuickCheck
|
||||||
Servant.QuickCheck.Internal.HasGenRequest
|
, Servant.QuickCheck.Internal.Equality
|
||||||
Servant.QuickCheck.Internal.Predicates
|
build-depends: base >=4.7 && <4.9
|
||||||
Servant.QuickCheck.Internal.QuickCheck
|
, base-compat == 0.9.*
|
||||||
|
, QuickCheck == 2.8.*
|
||||||
|
, bytestring == 0.10.*
|
||||||
|
, aeson > 0.10 && < 0.12
|
||||||
|
, mtl == 2.2.*
|
||||||
|
, http-client == 0.4.*
|
||||||
|
, http-types == 0.9.*
|
||||||
|
, http-media == 0.6.*
|
||||||
|
, servant-client == 0.7.*
|
||||||
|
, servant-server == 0.7.*
|
||||||
|
, string-conversions == 0.4.*
|
||||||
|
, data-default-class == 0.0.*
|
||||||
|
, servant == 0.7.*
|
||||||
|
, warp >= 3.2.4 && < 3.3
|
||||||
|
, process == 1.2.*
|
||||||
|
, temporary == 1.2.*
|
||||||
|
, split == 0.2.*
|
||||||
|
, case-insensitive == 1.2.*
|
||||||
|
, hspec == 2.2.*
|
||||||
|
, text == 1.*
|
||||||
|
if impl(ghc < 7.10)
|
||||||
|
build-depends: bifunctors == 5.*
|
||||||
|
|
||||||
build-depends:
|
hs-source-dirs: src
|
||||||
aeson >=0.8 && <2
|
default-extensions: TypeOperators
|
||||||
, base >=4.9 && <4.15
|
, FlexibleInstances
|
||||||
, base-compat-batteries >=0.10.1 && <0.12
|
, FlexibleContexts
|
||||||
, bytestring >=0.10 && <0.11
|
, DataKinds
|
||||||
, case-insensitive >=1.2 && <1.3
|
, GADTs
|
||||||
, clock >=0.7 && <0.9
|
, MultiParamTypeClasses
|
||||||
, data-default-class >=0.0 && <0.2
|
, DeriveFunctor
|
||||||
, hspec >=2.5.6 && <2.8
|
, KindSignatures
|
||||||
, http-client >=0.4.30 && <0.8
|
, RankNTypes
|
||||||
, http-media >=0.6 && <0.9
|
, ConstraintKinds
|
||||||
, http-types >=0.8 && <0.13
|
, DeriveGeneric
|
||||||
, mtl >=2.1 && <2.3
|
, ScopedTypeVariables
|
||||||
, pretty >=1.1 && <1.2
|
, OverloadedStrings
|
||||||
, process >=1.2 && <1.7
|
, FunctionalDependencies
|
||||||
, QuickCheck >=2.7 && <2.15
|
, NoImplicitPrelude
|
||||||
, servant >=0.17 && <0.19
|
default-language: Haskell2010
|
||||||
, servant-client >=0.17 && <0.19
|
|
||||||
, servant-server >=0.17 && <0.19
|
|
||||||
, split >=0.2 && <0.3
|
|
||||||
, string-conversions >=0.3 && <0.5
|
|
||||||
, temporary >=1.2 && <1.4
|
|
||||||
, text >=1 && <2
|
|
||||||
, time >=1.5 && <1.11
|
|
||||||
, warp >=3.2.4 && <3.4
|
|
||||||
|
|
||||||
if !impl(ghc >=8.0)
|
|
||||||
build-depends: semigroups >=0.18.3 && <0.20
|
|
||||||
|
|
||||||
hs-source-dirs: src
|
|
||||||
default-extensions:
|
|
||||||
NoImplicitPrelude
|
|
||||||
ConstraintKinds
|
|
||||||
DataKinds
|
|
||||||
DeriveDataTypeable
|
|
||||||
DeriveFunctor
|
|
||||||
DeriveGeneric
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
FunctionalDependencies
|
|
||||||
GADTs
|
|
||||||
KindSignatures
|
|
||||||
MultiParamTypeClasses
|
|
||||||
OverloadedStrings
|
|
||||||
RankNTypes
|
|
||||||
ScopedTypeVariables
|
|
||||||
TypeOperators
|
|
||||||
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|
||||||
test-suite spec
|
test-suite spec
|
||||||
type: exitcode-stdio-1.0
|
type: exitcode-stdio-1.0
|
||||||
ghc-options: -Wall -threaded
|
ghc-options: -Wall -threaded
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
hs-source-dirs: test
|
hs-source-dirs: test
|
||||||
main-is: Spec.hs
|
main-is: Spec.hs
|
||||||
other-modules: Servant.QuickCheck.InternalSpec
|
other-modules: Servant.QuickCheck.InternalSpec
|
||||||
build-tool-depends: hspec-discover:hspec-discover -any
|
build-depends: base == 4.*
|
||||||
build-depends:
|
, base-compat
|
||||||
aeson
|
, servant-quickcheck
|
||||||
, base
|
, hspec
|
||||||
, base-compat-batteries
|
, http-client
|
||||||
, blaze-html
|
, warp
|
||||||
, bytestring
|
, servant-server
|
||||||
, hspec
|
, servant-client
|
||||||
, hspec-core >=2.5.5 && <2.8
|
, servant
|
||||||
, http-client
|
, transformers
|
||||||
, QuickCheck
|
, QuickCheck
|
||||||
, quickcheck-io
|
, quickcheck-io
|
||||||
, servant
|
default-extensions: TypeOperators
|
||||||
, servant-blaze
|
, FlexibleInstances
|
||||||
, servant-client
|
, FlexibleContexts
|
||||||
, servant-quickcheck
|
, DataKinds
|
||||||
, servant-server
|
, NoImplicitPrelude
|
||||||
, transformers
|
|
||||||
, warp
|
|
||||||
|
|
||||||
default-extensions:
|
|
||||||
NoImplicitPrelude
|
|
||||||
DataKinds
|
|
||||||
FlexibleContexts
|
|
||||||
FlexibleInstances
|
|
||||||
GADTs
|
|
||||||
OverloadedStrings
|
|
||||||
ScopedTypeVariables
|
|
||||||
TypeOperators
|
|
||||||
|
|
||||||
if flag(long-tests)
|
if flag(long-tests)
|
||||||
cpp-options: -DLONG_TESTS
|
cpp-options: -DLONG_TESTS
|
||||||
|
|
||||||
test-suite example
|
|
||||||
type: exitcode-stdio-1.0
|
|
||||||
main-is: Main.hs
|
|
||||||
hs-source-dirs: example
|
|
||||||
ghc-options: -Wall
|
|
||||||
build-depends:
|
|
||||||
base
|
|
||||||
, hspec
|
|
||||||
, servant-quickcheck
|
|
||||||
, servant-server
|
|
||||||
, text
|
|
||||||
|
|
||||||
default-language: Haskell2010
|
|
||||||
|
|||||||
@ -27,18 +27,12 @@ module Servant.QuickCheck
|
|||||||
-- in RFCs. The __Best Practices__ includes, in addition to RFC
|
-- in RFCs. The __Best Practices__ includes, in addition to RFC
|
||||||
-- recommendations, recommendations found elsewhere or generally accepted.
|
-- recommendations, recommendations found elsewhere or generally accepted.
|
||||||
, not500
|
, not500
|
||||||
, notLongerThan
|
|
||||||
, onlyJsonObjects
|
, onlyJsonObjects
|
||||||
, honoursAcceptHeader
|
|
||||||
, notAllowedContainsAllowHeader
|
, notAllowedContainsAllowHeader
|
||||||
, unauthorizedContainsWWWAuthenticate
|
, unauthorizedContainsWWWAuthenticate
|
||||||
, getsHaveLastModifiedHeader
|
|
||||||
, getsHaveCacheControlHeader
|
, getsHaveCacheControlHeader
|
||||||
, headsHaveCacheControlHeader
|
, headsHaveCacheControlHeader
|
||||||
, createContainsValidLocation
|
, createContainsValidLocation
|
||||||
-- * Html Predicates
|
|
||||||
, htmlIncludesDoctype
|
|
||||||
|
|
||||||
-- *** Predicate utilities and types
|
-- *** Predicate utilities and types
|
||||||
, (<%>)
|
, (<%>)
|
||||||
, Predicates
|
, Predicates
|
||||||
@ -54,7 +48,6 @@ module Servant.QuickCheck
|
|||||||
-- represents other means of checking equality
|
-- represents other means of checking equality
|
||||||
-- *** Useful @ResponseEquality@s
|
-- *** Useful @ResponseEquality@s
|
||||||
, bodyEquality
|
, bodyEquality
|
||||||
, jsonEquality
|
|
||||||
, allEquality
|
, allEquality
|
||||||
-- ** Response equality type
|
-- ** Response equality type
|
||||||
, ResponseEquality(..)
|
, ResponseEquality(..)
|
||||||
@ -76,10 +69,10 @@ module Servant.QuickCheck
|
|||||||
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Proxy (Proxy (..))
|
|
||||||
import Servant.Client (BaseUrl (..), Scheme (..))
|
|
||||||
import Servant.QuickCheck.Internal
|
import Servant.QuickCheck.Internal
|
||||||
import Test.QuickCheck (Args (..), stdArgs)
|
import Servant.Client (BaseUrl(..), Scheme(..))
|
||||||
|
import Test.QuickCheck (Args(..), stdArgs)
|
||||||
|
import Data.Proxy (Proxy(..))
|
||||||
|
|
||||||
-- | QuickCheck @Args@ with 1000 rather than 100 test cases.
|
-- | QuickCheck @Args@ with 1000 rather than 100 test cases.
|
||||||
--
|
--
|
||||||
|
|||||||
@ -1,7 +1,6 @@
|
|||||||
module Servant.QuickCheck.Internal (module X) where
|
module Servant.QuickCheck.Internal (module X) where
|
||||||
|
|
||||||
import Servant.QuickCheck.Internal.Equality as X
|
|
||||||
import Servant.QuickCheck.Internal.ErrorTypes as X
|
|
||||||
import Servant.QuickCheck.Internal.HasGenRequest as X
|
import Servant.QuickCheck.Internal.HasGenRequest as X
|
||||||
import Servant.QuickCheck.Internal.Predicates as X
|
import Servant.QuickCheck.Internal.Predicates as X
|
||||||
import Servant.QuickCheck.Internal.QuickCheck as X
|
import Servant.QuickCheck.Internal.QuickCheck as X
|
||||||
|
import Servant.QuickCheck.Internal.Equality as X
|
||||||
|
|||||||
@ -1,23 +1,16 @@
|
|||||||
module Servant.QuickCheck.Internal.Equality where
|
module Servant.QuickCheck.Internal.Equality where
|
||||||
|
|
||||||
import Data.Aeson (Value, decode, decodeStrict)
|
import Data.Function (on)
|
||||||
import Data.ByteString (ByteString)
|
import Network.HTTP.Client (Response, responseBody)
|
||||||
import qualified Data.ByteString.Lazy as LB
|
import Prelude.Compat
|
||||||
import Data.Function (on)
|
|
||||||
import Network.HTTP.Client (Response, responseBody)
|
|
||||||
import Data.Semigroup (Semigroup (..))
|
|
||||||
import Prelude.Compat
|
|
||||||
|
|
||||||
newtype ResponseEquality b
|
newtype ResponseEquality b
|
||||||
= ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
|
= ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
|
||||||
|
|
||||||
instance Semigroup (ResponseEquality b) where
|
|
||||||
ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y ->
|
|
||||||
a x y && b x y
|
|
||||||
|
|
||||||
instance Monoid (ResponseEquality b) where
|
instance Monoid (ResponseEquality b) where
|
||||||
mempty = ResponseEquality $ \_ _ -> True
|
mempty = ResponseEquality $ \_ _ -> True
|
||||||
mappend = (<>)
|
ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->
|
||||||
|
a x y && b x y
|
||||||
|
|
||||||
-- | Use `Eq` instance for `Response`
|
-- | Use `Eq` instance for `Response`
|
||||||
--
|
--
|
||||||
@ -30,29 +23,3 @@ allEquality = ResponseEquality (==)
|
|||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
bodyEquality :: Eq b => ResponseEquality b
|
bodyEquality :: Eq b => ResponseEquality b
|
||||||
bodyEquality = ResponseEquality ((==) `on` responseBody)
|
bodyEquality = ResponseEquality ((==) `on` responseBody)
|
||||||
|
|
||||||
-- | Equality as 'Value'. This means that if two bodies are equal as JSON
|
|
||||||
-- (e.g., insignificant whitespace difference) they are considered equal.
|
|
||||||
--
|
|
||||||
-- /Since 0.0.3.0/
|
|
||||||
jsonEquality :: (JsonEq b) => ResponseEquality b
|
|
||||||
jsonEquality = ResponseEquality (jsonEq `on` responseBody)
|
|
||||||
|
|
||||||
class JsonEq a where
|
|
||||||
decode' :: a -> Maybe Value
|
|
||||||
jsonEq :: a -> a -> Bool
|
|
||||||
jsonEq first second = compareDecodedResponses (decode' first) (decode' second)
|
|
||||||
|
|
||||||
instance JsonEq LB.ByteString where
|
|
||||||
decode' = decode
|
|
||||||
|
|
||||||
instance JsonEq ByteString where
|
|
||||||
decode' = decodeStrict
|
|
||||||
|
|
||||||
compareDecodedResponses :: Maybe Value -> Maybe Value -> Bool
|
|
||||||
compareDecodedResponses resp1 resp2 =
|
|
||||||
case resp1 of
|
|
||||||
Nothing -> False -- if decoding fails we assume failure
|
|
||||||
(Just r1) -> case resp2 of
|
|
||||||
Nothing -> False -- another decode failure
|
|
||||||
(Just r2) -> r1 == r2
|
|
||||||
|
|||||||
@ -1,82 +0,0 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
module Servant.QuickCheck.Internal.ErrorTypes where
|
|
||||||
|
|
||||||
import Control.Exception (Exception (..))
|
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
|
||||||
import Data.String.Conversions (cs)
|
|
||||||
import qualified Data.Text as T
|
|
||||||
import Data.Typeable (Typeable)
|
|
||||||
import GHC.Generics (Generic)
|
|
||||||
import qualified Network.HTTP.Client as C
|
|
||||||
import Network.HTTP.Types (Header, statusCode)
|
|
||||||
import Text.PrettyPrint
|
|
||||||
|
|
||||||
import Prelude.Compat hiding ((<>))
|
|
||||||
|
|
||||||
data PredicateFailure
|
|
||||||
= PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
|
|
||||||
deriving (Typeable, Generic)
|
|
||||||
|
|
||||||
instance Exception ServerEqualityFailure where
|
|
||||||
|
|
||||||
instance Show PredicateFailure where
|
|
||||||
show = render . prettyPredicateFailure
|
|
||||||
|
|
||||||
|
|
||||||
data ServerEqualityFailure
|
|
||||||
= ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)
|
|
||||||
deriving (Typeable, Generic)
|
|
||||||
|
|
||||||
instance Show ServerEqualityFailure where
|
|
||||||
show = render . prettyServerEqualityFailure
|
|
||||||
|
|
||||||
|
|
||||||
instance Exception PredicateFailure where
|
|
||||||
|
|
||||||
-- * Pretty printing
|
|
||||||
|
|
||||||
prettyHeaders :: [Header] -> Doc
|
|
||||||
prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs
|
|
||||||
where
|
|
||||||
prettyHdr (hn, h) = text (show hn) <> colon <+> text (show h)
|
|
||||||
|
|
||||||
prettyReq :: C.Request -> Doc
|
|
||||||
prettyReq r =
|
|
||||||
text "Request:" $$ (nest 5 $
|
|
||||||
text "Method:" <+> (nest 5 $ text . show $ C.method r)
|
|
||||||
$$ text "Path:" <+> (nest 5 $ text . cs $ C.path r)
|
|
||||||
$$ text "Headers:" <+> (nest 5 $ prettyHeaders $ C.requestHeaders r)
|
|
||||||
$$ text "Body:" <+> (nest 5 $ text . getReqBody $ C.requestBody r))
|
|
||||||
where
|
|
||||||
getReqBody (C.RequestBodyLBS lbs ) = cs lbs
|
|
||||||
getReqBody (C.RequestBodyBS bs ) = cs bs
|
|
||||||
getReqBody _ = error "expected bytestring body"
|
|
||||||
|
|
||||||
prettyResp :: C.Response LBS.ByteString -> Doc
|
|
||||||
prettyResp r =
|
|
||||||
text "Response:" $$ (nest 5 $
|
|
||||||
text "Status code:" <+> (nest 5 $ text . show . statusCode $ C.responseStatus r)
|
|
||||||
$$ text "Headers:" $$ (nest 10 $ prettyHeaders $ C.responseHeaders r)
|
|
||||||
$$ text "Body:" <+> (nest 5 $ text . cs $ C.responseBody r))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
prettyServerEqualityFailure :: ServerEqualityFailure -> Doc
|
|
||||||
prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =
|
|
||||||
text "Server equality failed" $$ (nest 5 $
|
|
||||||
prettyReq req
|
|
||||||
$$ prettyResp resp1
|
|
||||||
$$ prettyResp resp2)
|
|
||||||
|
|
||||||
|
|
||||||
prettyPredicateFailure :: PredicateFailure -> Doc
|
|
||||||
prettyPredicateFailure (PredicateFailure predicate req resp) =
|
|
||||||
text "Predicate failed" $$ (nest 5 $
|
|
||||||
text "Predicate:" <+> (text $ T.unpack predicate)
|
|
||||||
$$ r
|
|
||||||
$$ prettyResp resp)
|
|
||||||
where
|
|
||||||
r = case req of
|
|
||||||
Nothing -> text ""
|
|
||||||
Just v -> prettyReq v
|
|
||||||
|
|
||||||
@ -1,148 +1,98 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
|
||||||
{-# LANGUAGE PolyKinds #-}
|
{-# LANGUAGE PolyKinds #-}
|
||||||
module Servant.QuickCheck.Internal.HasGenRequest where
|
module Servant.QuickCheck.Internal.HasGenRequest where
|
||||||
|
|
||||||
import Data.String (fromString)
|
import Data.Default.Class (def)
|
||||||
import Data.String.Conversions (cs)
|
import Data.Monoid ((<>))
|
||||||
import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
|
import Data.String (fromString)
|
||||||
import Network.HTTP.Client (Request, RequestBody (..), host, method, path,
|
import Data.String.Conversions (cs)
|
||||||
port, queryString, requestBody, requestHeaders,
|
import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
|
||||||
secure, defaultRequest)
|
import Network.HTTP.Client (Request, RequestBody (..), host,
|
||||||
import Network.HTTP.Media (renderHeader)
|
method, path, port, queryString,
|
||||||
import Prelude.Compat
|
requestBody, requestHeaders, secure)
|
||||||
import Servant
|
import Network.HTTP.Media (renderHeader)
|
||||||
import Servant.API.ContentTypes (AllMimeRender (..))
|
import Prelude.Compat
|
||||||
import Servant.Client (BaseUrl (..), Scheme (..))
|
import Servant
|
||||||
import Test.QuickCheck (Arbitrary (..), Gen, elements, frequency)
|
import Servant.API.ContentTypes (AllMimeRender (..))
|
||||||
|
import Servant.Client (BaseUrl (..), Scheme (..))
|
||||||
import qualified Data.ByteString as BS
|
import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)
|
||||||
import qualified Data.ByteString.Internal as BS (c2w)
|
|
||||||
|
|
||||||
|
|
||||||
-- -----------------------------------------------------------------------------
|
|
||||||
-- runGenRequest
|
|
||||||
|
|
||||||
-- | This function returns a QuickCheck `Gen a` when passed a servant API value,
|
|
||||||
-- typically a `Proxy API`. The generator returned is a function
|
|
||||||
-- that accepts a `BaseUrl` and returns a `Request`, which can then be used
|
|
||||||
-- to issue network requests. This `Gen` type makes it easier to compare distinct
|
|
||||||
-- APIs across different `BaseUrl`s.
|
|
||||||
runGenRequest :: HasGenRequest a => Proxy a -> Gen (BaseUrl -> Request)
|
|
||||||
runGenRequest = snd . genRequest
|
|
||||||
|
|
||||||
|
|
||||||
-- -----------------------------------------------------------------------------
|
|
||||||
-- HasGenRequest
|
|
||||||
|
|
||||||
-- | This is the core Servant-Quickcheck generator, which, when given a `Proxy API`
|
|
||||||
-- will return a pair of `Int` and `Gen a`, where `a` is a function from
|
|
||||||
-- `BaseUrl` to a `Network.Http.Client.Request`. The `Int` is a weight for the
|
|
||||||
-- QuickCheck `frequency` function which ensures a random distribution across
|
|
||||||
-- all endpoints in an API.
|
|
||||||
class HasGenRequest a where
|
class HasGenRequest a where
|
||||||
genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))
|
genRequest :: Proxy a -> Gen (BaseUrl -> Request)
|
||||||
|
|
||||||
|
|
||||||
instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
|
instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
|
||||||
genRequest _
|
genRequest _
|
||||||
= (lf + rf, frequency [l, r])
|
= oneof [ genRequest (Proxy :: Proxy a)
|
||||||
where
|
, genRequest (Proxy :: Proxy b)
|
||||||
l@(lf, _) = genRequest (Proxy :: Proxy a)
|
]
|
||||||
r@(rf, _) = genRequest (Proxy :: Proxy b)
|
|
||||||
|
|
||||||
|
|
||||||
instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
|
instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
|
||||||
genRequest _ = (oldf, do
|
genRequest _ = do
|
||||||
old' <- old
|
old' <- old
|
||||||
return $ \burl -> let r = old' burl
|
return $ \burl -> let r = old' burl in r { path = new <> "/" <> path r }
|
||||||
oldPath = path r
|
|
||||||
oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
|
|
||||||
paths = filter (not . BS.null) [new, oldPath']
|
|
||||||
in r { path = "/" <> BS.intercalate "/" paths })
|
|
||||||
where
|
where
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
old = genRequest (Proxy :: Proxy b)
|
||||||
new = cs $ symbolVal (Proxy :: Proxy path)
|
new = cs $ symbolVal (Proxy :: Proxy path)
|
||||||
|
|
||||||
instance HasGenRequest EmptyAPI where
|
|
||||||
genRequest _ = (0, error "EmptyAPIs cannot be queried.")
|
|
||||||
|
|
||||||
instance HasGenRequest api => HasGenRequest (Summary d :> api) where
|
|
||||||
genRequest _ = genRequest (Proxy :: Proxy api)
|
|
||||||
|
|
||||||
instance HasGenRequest api => HasGenRequest (Description d :> api) where
|
|
||||||
genRequest _ = genRequest (Proxy :: Proxy api)
|
|
||||||
|
|
||||||
instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
|
instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
|
||||||
=> HasGenRequest (Capture' mods x c :> b) where
|
=> HasGenRequest (Capture x c :> b) where
|
||||||
genRequest _ = (oldf, do
|
genRequest _ = do
|
||||||
old' <- old
|
old' <- old
|
||||||
new' <- toUrlPiece <$> new
|
new' <- toUrlPiece <$> new
|
||||||
return $ \burl -> let r = old' burl in r { path = cs new' <> path r })
|
return $ \burl -> let r = old' burl in r { path = cs new' <> "/" <> path r }
|
||||||
where
|
where
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
old = genRequest (Proxy :: Proxy b)
|
||||||
new = arbitrary :: Gen c
|
new = arbitrary :: Gen c
|
||||||
|
|
||||||
instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
|
|
||||||
=> HasGenRequest (CaptureAll x c :> b) where
|
|
||||||
genRequest _ = (oldf, do
|
|
||||||
old' <- old
|
|
||||||
new' <- fmap (cs . toUrlPiece) <$> new
|
|
||||||
let new'' = BS.intercalate "/" new'
|
|
||||||
return $ \burl -> let r = old' burl in r { path = new'' <> path r })
|
|
||||||
where
|
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
|
||||||
new = arbitrary :: Gen [c]
|
|
||||||
|
|
||||||
instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
|
instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
|
||||||
=> HasGenRequest (Header' mods h c :> b) where
|
=> HasGenRequest (Header h c :> b) where
|
||||||
genRequest _ = (oldf, do
|
genRequest _ = do
|
||||||
old' <- old
|
old' <- old
|
||||||
new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
|
new' <- toUrlPiece <$> new
|
||||||
return $ \burl -> let r = old' burl in r {
|
return $ \burl -> let r = old' burl in r {
|
||||||
requestHeaders = (hdr, cs new') : requestHeaders r })
|
requestHeaders = (hdr, cs new') : requestHeaders r }
|
||||||
where
|
where
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
old = genRequest (Proxy :: Proxy b)
|
||||||
hdr = fromString $ symbolVal (Proxy :: Proxy h)
|
hdr = fromString $ symbolVal (Proxy :: Proxy h)
|
||||||
new = arbitrary :: Gen c
|
new = arbitrary :: Gen c
|
||||||
|
|
||||||
instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
|
instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
|
||||||
=> HasGenRequest (ReqBody' mods x c :> b) where
|
=> HasGenRequest (ReqBody x c :> b) where
|
||||||
genRequest _ = (oldf, do
|
genRequest _ = do
|
||||||
old' <- old -- TODO: generate lenient
|
old' <- old
|
||||||
new' <- new
|
new' <- new
|
||||||
(ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
|
(ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
|
||||||
return $ \burl -> let r = old' burl in r {
|
return $ \burl -> let r = old' burl in r {
|
||||||
requestBody = RequestBodyLBS bd
|
requestBody = RequestBodyLBS bd
|
||||||
, requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
|
, requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
|
||||||
})
|
}
|
||||||
where
|
where
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
old = genRequest (Proxy :: Proxy b)
|
||||||
new = arbitrary :: Gen c
|
new = arbitrary :: Gen c
|
||||||
|
|
||||||
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
||||||
=> HasGenRequest (QueryParam' mods x c :> b) where
|
=> HasGenRequest (QueryParam x c :> b) where
|
||||||
genRequest _ = (oldf, do
|
genRequest _ = do
|
||||||
new' <- new -- TODO: generate lenient or/and optional
|
new' <- new
|
||||||
old' <- old
|
old' <- old
|
||||||
return $ \burl -> let r = old' burl
|
return $ \burl -> let r = old' burl in r {
|
||||||
newExpr = param <> "=" <> cs (toQueryParam new')
|
queryString = queryString r
|
||||||
qs = queryString r in r {
|
<> param <> "=" <> cs (toQueryParam new') }
|
||||||
queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
|
|
||||||
where
|
where
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
old = genRequest (Proxy :: Proxy b)
|
||||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
new = arbitrary :: Gen c
|
new = arbitrary :: Gen c
|
||||||
|
|
||||||
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
||||||
=> HasGenRequest (QueryParams x c :> b) where
|
=> HasGenRequest (QueryParams x c :> b) where
|
||||||
genRequest _ = (oldf, do
|
genRequest _ = do
|
||||||
new' <- new
|
new' <- new
|
||||||
old' <- old
|
old' <- old
|
||||||
return $ \burl -> let r = old' burl in r {
|
return $ \burl -> let r = old' burl in r {
|
||||||
queryString = queryString r
|
queryString = queryString r
|
||||||
<> if length new' > 0 then fold (toParam <$> new') else ""})
|
<> if length new' > 0 then fold (toParam <$> new') else ""}
|
||||||
where
|
where
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
old = genRequest (Proxy :: Proxy b)
|
||||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
new = arbitrary :: Gen [c]
|
new = arbitrary :: Gen [c]
|
||||||
toParam c = param <> "[]=" <> cs (toQueryParam c)
|
toParam c = param <> "[]=" <> cs (toQueryParam c)
|
||||||
@ -150,32 +100,22 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
|
|||||||
|
|
||||||
instance (KnownSymbol x, HasGenRequest b)
|
instance (KnownSymbol x, HasGenRequest b)
|
||||||
=> HasGenRequest (QueryFlag x :> b) where
|
=> HasGenRequest (QueryFlag x :> b) where
|
||||||
genRequest _ = (oldf, do
|
genRequest _ = do
|
||||||
old' <- old
|
old' <- old
|
||||||
return $ \burl -> let r = old' burl
|
return $ \burl -> let r = old' burl in r {
|
||||||
qs = queryString r in r {
|
queryString = queryString r <> param <> "=" }
|
||||||
queryString = if BS.null qs then param else param <> "&" <> qs })
|
|
||||||
where
|
where
|
||||||
(oldf, old) = genRequest (Proxy :: Proxy b)
|
old = genRequest (Proxy :: Proxy b)
|
||||||
param = cs $ symbolVal (Proxy :: Proxy x)
|
param = cs $ symbolVal (Proxy :: Proxy x)
|
||||||
|
|
||||||
instance (ReflectMethod method)
|
instance (ReflectMethod method)
|
||||||
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
|
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
|
||||||
genRequest _ = (1, return $ \burl -> defaultRequest
|
genRequest _ = return $ \burl -> def
|
||||||
{ host = cs $ baseUrlHost burl
|
{ host = cs $ baseUrlHost burl
|
||||||
, port = baseUrlPort burl
|
, port = baseUrlPort burl
|
||||||
, secure = baseUrlScheme burl == Https
|
, secure = baseUrlScheme burl == Https
|
||||||
, method = reflectMethod (Proxy :: Proxy method)
|
, method = reflectMethod (Proxy :: Proxy method)
|
||||||
})
|
}
|
||||||
|
|
||||||
instance (ReflectMethod method)
|
|
||||||
=> HasGenRequest (NoContentVerb (method :: k)) where
|
|
||||||
genRequest _ = (1, return $ \burl -> defaultRequest
|
|
||||||
{ host = cs $ baseUrlHost burl
|
|
||||||
, port = baseUrlPort burl
|
|
||||||
, secure = baseUrlScheme burl == Https
|
|
||||||
, method = reflectMethod (Proxy :: Proxy method)
|
|
||||||
})
|
|
||||||
|
|
||||||
instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
|
instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
|
||||||
genRequest _ = genRequest (Proxy :: Proxy a)
|
genRequest _ = genRequest (Proxy :: Proxy a)
|
||||||
|
|||||||
@ -1,36 +1,28 @@
|
|||||||
module Servant.QuickCheck.Internal.Predicates where
|
module Servant.QuickCheck.Internal.Predicates where
|
||||||
|
|
||||||
import Control.Exception (catch, throw)
|
import Control.Monad (liftM2)
|
||||||
import Control.Monad (liftM2, unless, when)
|
|
||||||
import Data.Aeson (Object, decode)
|
import Data.Aeson (Object, decode)
|
||||||
import Data.Bifunctor (first)
|
import Data.Bifunctor (Bifunctor (..))
|
||||||
|
import Prelude.Compat
|
||||||
import qualified Data.ByteString as SBS
|
import qualified Data.ByteString as SBS
|
||||||
import qualified Data.ByteString.Char8 as SBSC
|
import qualified Data.ByteString.Char8 as SBSC
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import Data.CaseInsensitive (foldCase, foldedCase, mk)
|
import Data.CaseInsensitive (mk)
|
||||||
import Data.Either (isRight)
|
import Data.Either (isRight)
|
||||||
import Data.List.Split (wordsBy)
|
import Data.List.Split (wordsBy)
|
||||||
import Data.Maybe (fromMaybe, isJust)
|
import Data.Maybe (fromMaybe, isJust)
|
||||||
import Data.Semigroup (Semigroup (..))
|
import Data.Monoid ((<>))
|
||||||
import qualified Data.Text as T
|
import Data.Text (Text)
|
||||||
import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
|
|
||||||
rfc822DateFormat)
|
|
||||||
import GHC.Generics (Generic)
|
import GHC.Generics (Generic)
|
||||||
import Network.HTTP.Client (Manager, Request, Response, httpLbs,
|
import Network.HTTP.Client (Manager, Request, Response, httpLbs,
|
||||||
method, parseRequest, requestHeaders,
|
method, parseUrl, requestHeaders,
|
||||||
responseBody, responseHeaders,
|
responseBody, responseHeaders,
|
||||||
responseStatus)
|
responseStatus)
|
||||||
import Network.HTTP.Media (matchAccept)
|
import Network.HTTP.Media (matchAccept)
|
||||||
import Network.HTTP.Types (methodGet, methodHead, parseMethod,
|
import Network.HTTP.Types (methodGet, methodHead, parseMethod,
|
||||||
renderStdMethod, status100, status200,
|
renderStdMethod, status200, status201,
|
||||||
status201, status300, status401,
|
status300, status401, status405,
|
||||||
status405, status500)
|
status500, status100)
|
||||||
import Prelude.Compat
|
|
||||||
import System.Clock (Clock (Monotonic), diffTimeSpec,
|
|
||||||
getTime, toNanoSecs)
|
|
||||||
|
|
||||||
import Servant.QuickCheck.Internal.ErrorTypes
|
|
||||||
|
|
||||||
|
|
||||||
-- | [__Best Practice__]
|
-- | [__Best Practice__]
|
||||||
--
|
--
|
||||||
@ -41,25 +33,8 @@ import Servant.QuickCheck.Internal.ErrorTypes
|
|||||||
-- This function checks that the response code is not 500.
|
-- This function checks that the response code is not 500.
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
not500 :: ResponsePredicate
|
not500 :: ResponsePredicate Text Bool
|
||||||
not500 = ResponsePredicate $ \resp ->
|
not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
|
||||||
when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
|
|
||||||
|
|
||||||
-- | [__Optional__]
|
|
||||||
--
|
|
||||||
-- This function checks that the response from the server does not take longer
|
|
||||||
-- than the specified number of nanoseconds.
|
|
||||||
--
|
|
||||||
-- /Since 0.0.2.1/
|
|
||||||
notLongerThan :: Integer -> RequestPredicate
|
|
||||||
notLongerThan maxAllowed
|
|
||||||
= RequestPredicate $ \req mgr -> do
|
|
||||||
start <- getTime Monotonic
|
|
||||||
resp <- httpLbs req mgr
|
|
||||||
end <- getTime Monotonic
|
|
||||||
when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $
|
|
||||||
throw $ PredicateFailure "notLongerThan" (Just req) resp
|
|
||||||
return []
|
|
||||||
|
|
||||||
-- | [__Best Practice__]
|
-- | [__Best Practice__]
|
||||||
--
|
--
|
||||||
@ -82,15 +57,11 @@ notLongerThan maxAllowed
|
|||||||
-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
|
-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
onlyJsonObjects :: ResponsePredicate
|
onlyJsonObjects :: ResponsePredicate Text Bool
|
||||||
onlyJsonObjects
|
onlyJsonObjects
|
||||||
= ResponsePredicate (\resp -> do
|
= ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
|
||||||
case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
|
Nothing -> False
|
||||||
Nothing -> return ()
|
Just (_ :: Object) -> True)
|
||||||
Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do
|
|
||||||
case (decode (responseBody resp) :: Maybe Object) of
|
|
||||||
Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
|
|
||||||
Just _ -> return ())
|
|
||||||
|
|
||||||
-- | __Optional__
|
-- | __Optional__
|
||||||
--
|
--
|
||||||
@ -111,59 +82,29 @@ onlyJsonObjects
|
|||||||
-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
|
-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
createContainsValidLocation :: RequestPredicate
|
createContainsValidLocation :: RequestPredicate Text Bool
|
||||||
createContainsValidLocation
|
createContainsValidLocation
|
||||||
= RequestPredicate $ \req mgr -> do
|
= RequestPredicate
|
||||||
let n = "createContainsValidLocation"
|
{ reqPredName = "createContainsValidLocation"
|
||||||
resp <- httpLbs req mgr
|
, reqResps = \req mgr -> do
|
||||||
if responseStatus resp == status201
|
|
||||||
then case lookup "Location" $ responseHeaders resp of
|
|
||||||
Nothing -> throw $ PredicateFailure n (Just req) resp
|
|
||||||
Just l -> case parseRequest $ SBSC.unpack l of
|
|
||||||
Nothing -> throw $ PredicateFailure n (Just req) resp
|
|
||||||
Just x -> do
|
|
||||||
resp2 <- httpLbs x mgr
|
|
||||||
status2XX (Just req) resp2 n
|
|
||||||
return [resp, resp2]
|
|
||||||
else return [resp]
|
|
||||||
|
|
||||||
-- | [__Optional__]
|
|
||||||
--
|
|
||||||
-- The @Last-Modified@ header represents the time a resource was last
|
|
||||||
-- modified. It is used to drive caching and conditional requests.
|
|
||||||
--
|
|
||||||
-- When using this mechanism, the server adds the @Last-Modified@ header to
|
|
||||||
-- responses. Clients may then make requests with the @If-Modified-Since@
|
|
||||||
-- header to conditionally request resources. If the resource has not
|
|
||||||
-- changed since that date, the server responds with a status code of 304
|
|
||||||
-- (@Not Modified@) without a response body.
|
|
||||||
--
|
|
||||||
-- The @Last-Modified@ header can also be used in conjunction with the
|
|
||||||
-- @If-Unmodified-Since@ header to drive optimistic concurrency.
|
|
||||||
--
|
|
||||||
-- The @Last-Modified@ date must be in RFC 822 format.
|
|
||||||
--
|
|
||||||
-- __References__:
|
|
||||||
--
|
|
||||||
-- * 304 Not Modified: <https://tools.ietf.org/html/rfc7232#section-4.1 RFC 7232 Section 4.1>
|
|
||||||
-- * Last-Modified header: <https://tools.ietf.org/html/rfc7232#section-2.2 RFC 7232 Section 2.2>
|
|
||||||
-- * If-Modified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.3 RFC 7232 Section 3.3>
|
|
||||||
-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
|
|
||||||
-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
|
|
||||||
--
|
|
||||||
-- /Since 0.0.2.1/
|
|
||||||
getsHaveLastModifiedHeader :: RequestPredicate
|
|
||||||
getsHaveLastModifiedHeader
|
|
||||||
= RequestPredicate $ \req mgr ->
|
|
||||||
if (method req == methodGet)
|
|
||||||
then do
|
|
||||||
resp <- httpLbs req mgr
|
resp <- httpLbs req mgr
|
||||||
unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
|
if responseStatus resp == status201
|
||||||
throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
|
then case lookup "Location" $ responseHeaders resp of
|
||||||
return [resp]
|
Nothing -> return (False, [resp])
|
||||||
else return []
|
Just l -> case parseUrl $ SBSC.unpack l of
|
||||||
|
Nothing -> return (False, [resp])
|
||||||
|
Just x -> do
|
||||||
|
resp2 <- httpLbs x mgr
|
||||||
|
return (status2XX resp2, [resp, resp2])
|
||||||
|
else return (True, [resp])
|
||||||
|
}
|
||||||
|
|
||||||
|
{-
|
||||||
|
getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
|
||||||
|
getsHaveLastModifiedHeader
|
||||||
|
= ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
|
||||||
|
|
||||||
|
-}
|
||||||
|
|
||||||
-- | [__RFC Compliance__]
|
-- | [__RFC Compliance__]
|
||||||
--
|
--
|
||||||
@ -175,27 +116,24 @@ getsHaveLastModifiedHeader
|
|||||||
-- This function checks that every @405 Method Not Allowed@ response contains
|
-- This function checks that every @405 Method Not Allowed@ response contains
|
||||||
-- an @Allow@ header with a list of standard HTTP methods.
|
-- an @Allow@ header with a list of standard HTTP methods.
|
||||||
--
|
--
|
||||||
-- Note that 'servant' itself does not currently set the @Allow@ headers.
|
|
||||||
--
|
|
||||||
-- __References__:
|
-- __References__:
|
||||||
--
|
--
|
||||||
-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
|
-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
|
||||||
-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
|
-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
|
||||||
-- * Servant Allow header issue: <https://github.com/haskell-servant/servant/issues/489 Issue #489>
|
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
notAllowedContainsAllowHeader :: RequestPredicate
|
notAllowedContainsAllowHeader :: RequestPredicate Text Bool
|
||||||
notAllowedContainsAllowHeader
|
notAllowedContainsAllowHeader
|
||||||
= RequestPredicate $ \req mgr -> do
|
= RequestPredicate
|
||||||
let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
|
{ reqPredName = "notAllowedContainsAllowHeader"
|
||||||
, renderStdMethod m /= method req ]
|
, reqResps = \req mgr -> do
|
||||||
resp <- mapM (flip httpLbs mgr) reqs
|
resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
|
||||||
|
| m <- [minBound .. maxBound ]
|
||||||
case filter pred' (zip reqs resp) of
|
, renderStdMethod m /= method req ]
|
||||||
(x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
|
return (all pred' resp, resp)
|
||||||
[] -> return resp
|
}
|
||||||
where
|
where
|
||||||
pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
|
pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
|
||||||
where
|
where
|
||||||
go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
|
go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
|
||||||
$ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
|
$ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
|
||||||
@ -216,19 +154,19 @@ notAllowedContainsAllowHeader
|
|||||||
-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
|
-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
honoursAcceptHeader :: RequestPredicate
|
honoursAcceptHeader :: RequestPredicate Text Bool
|
||||||
honoursAcceptHeader
|
honoursAcceptHeader
|
||||||
= RequestPredicate $ \req mgr -> do
|
= RequestPredicate
|
||||||
resp <- httpLbs req mgr
|
{ reqPredName = "honoursAcceptHeader"
|
||||||
let scode = responseStatus resp
|
, reqResps = \req mgr -> do
|
||||||
sctype = lookup "Content-Type" $ responseHeaders resp
|
resp <- httpLbs req mgr
|
||||||
sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
|
let scode = responseStatus resp
|
||||||
if status100 < scode && scode < status300
|
sctype = lookup "Content-Type" $ responseHeaders resp
|
||||||
then if isJust $ sctype >>= \x -> matchAccept [x] sacc
|
sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
|
||||||
then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
|
if status100 < scode && scode < status300
|
||||||
else return [resp]
|
then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])
|
||||||
else return [resp]
|
else return (True, [resp])
|
||||||
|
}
|
||||||
|
|
||||||
-- | [__Best Practice__]
|
-- | [__Best Practice__]
|
||||||
--
|
--
|
||||||
@ -244,32 +182,34 @@ honoursAcceptHeader
|
|||||||
-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
|
-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
getsHaveCacheControlHeader :: RequestPredicate
|
getsHaveCacheControlHeader :: RequestPredicate Text Bool
|
||||||
getsHaveCacheControlHeader
|
getsHaveCacheControlHeader
|
||||||
= RequestPredicate $ \req mgr ->
|
= RequestPredicate
|
||||||
if (method req == methodGet)
|
{ reqPredName = "getsHaveCacheControlHeader"
|
||||||
then do
|
, reqResps = \req mgr -> if method req == methodGet
|
||||||
resp <- httpLbs req mgr
|
then do
|
||||||
unless (hasValidHeader "Cache-Control" (const True) resp) $ do
|
resp <- httpLbs req mgr
|
||||||
throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
|
let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
|
||||||
return [resp]
|
return (good, [resp])
|
||||||
else return []
|
else return (True, [])
|
||||||
|
}
|
||||||
|
|
||||||
-- | [__Best Practice__]
|
-- | [__Best Practice__]
|
||||||
--
|
--
|
||||||
-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
|
-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
headsHaveCacheControlHeader :: RequestPredicate
|
headsHaveCacheControlHeader :: RequestPredicate Text Bool
|
||||||
headsHaveCacheControlHeader
|
headsHaveCacheControlHeader
|
||||||
= RequestPredicate $ \req mgr ->
|
= RequestPredicate
|
||||||
if (method req == methodHead)
|
{ reqPredName = "headsHaveCacheControlHeader"
|
||||||
then do
|
, reqResps = \req mgr -> if method req == methodHead
|
||||||
resp <- httpLbs req mgr
|
then do
|
||||||
unless (hasValidHeader "Cache-Control" (const True) resp) $
|
resp <- httpLbs req mgr
|
||||||
throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
|
let good = hasValidHeader "Cache-Control" (const True) resp
|
||||||
return [resp]
|
return (good, [resp])
|
||||||
else return []
|
else return (True, [])
|
||||||
|
}
|
||||||
{-
|
{-
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
@ -331,35 +271,12 @@ linkHeadersAreValid
|
|||||||
-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
|
-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
unauthorizedContainsWWWAuthenticate :: ResponsePredicate
|
unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
|
||||||
unauthorizedContainsWWWAuthenticate
|
unauthorizedContainsWWWAuthenticate
|
||||||
= ResponsePredicate $ \resp ->
|
= ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
|
||||||
if responseStatus resp == status401
|
if responseStatus resp == status401
|
||||||
then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
|
then hasValidHeader "WWW-Authenticate" (const True) resp
|
||||||
throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
|
else True)
|
||||||
else return ()
|
|
||||||
|
|
||||||
|
|
||||||
-- | [__RFC Compliance__]
|
|
||||||
--
|
|
||||||
-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
|
|
||||||
--
|
|
||||||
-- This function checks that HTML documents (those with `Content-Type: text/html...`)
|
|
||||||
-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
|
|
||||||
--
|
|
||||||
-- __References__:
|
|
||||||
--
|
|
||||||
-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
|
|
||||||
-- /Since 0.3.0.0/
|
|
||||||
htmlIncludesDoctype :: ResponsePredicate
|
|
||||||
htmlIncludesDoctype
|
|
||||||
= ResponsePredicate $ \resp ->
|
|
||||||
if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
|
|
||||||
then do
|
|
||||||
let htmlContent = foldCase . LBS.take 20 $ responseBody resp
|
|
||||||
unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
|
|
||||||
throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
|
|
||||||
else return ()
|
|
||||||
|
|
||||||
-- * Predicate logic
|
-- * Predicate logic
|
||||||
|
|
||||||
@ -372,56 +289,67 @@ htmlIncludesDoctype
|
|||||||
-- | A predicate that depends only on the response.
|
-- | A predicate that depends only on the response.
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
newtype ResponsePredicate = ResponsePredicate
|
data ResponsePredicate n r = ResponsePredicate
|
||||||
{ getResponsePredicate :: Response LBS.ByteString -> IO ()
|
{ respPredName :: n
|
||||||
} deriving (Generic)
|
, respPred :: Response LBS.ByteString -> r
|
||||||
|
} deriving (Functor, Generic)
|
||||||
|
|
||||||
instance Semigroup ResponsePredicate where
|
instance Bifunctor ResponsePredicate where
|
||||||
ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
|
first f (ResponsePredicate a b) = ResponsePredicate (f a) b
|
||||||
|
second = fmap
|
||||||
|
|
||||||
instance Monoid ResponsePredicate where
|
instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
|
||||||
mempty = ResponsePredicate $ const $ return ()
|
mempty = ResponsePredicate mempty mempty
|
||||||
mappend = (<>)
|
a `mappend` b = ResponsePredicate
|
||||||
|
{ respPredName = respPredName a <> respPredName b
|
||||||
|
, respPred = respPred a <> respPred b
|
||||||
|
}
|
||||||
|
|
||||||
-- | A predicate that depends on both the request and the response.
|
-- | A predicate that depends on both the request and the response.
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
newtype RequestPredicate = RequestPredicate
|
data RequestPredicate n r = RequestPredicate
|
||||||
{ getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
|
{ reqPredName :: n
|
||||||
} deriving (Generic)
|
, reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])
|
||||||
|
} deriving (Generic, Functor)
|
||||||
|
|
||||||
|
instance Bifunctor RequestPredicate where
|
||||||
|
first f (RequestPredicate a b) = RequestPredicate (f a) b
|
||||||
|
second = fmap
|
||||||
|
|
||||||
-- TODO: This isn't actually a monoid
|
-- TODO: This isn't actually a monoid
|
||||||
instance Monoid RequestPredicate where
|
instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
|
||||||
mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
|
mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
|
||||||
mappend = (<>)
|
a `mappend` b = RequestPredicate
|
||||||
|
{ reqPredName = reqPredName a <> reqPredName b
|
||||||
-- TODO: This isn't actually a monoid
|
, reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
|
||||||
instance Semigroup RequestPredicate where
|
}
|
||||||
RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
|
|
||||||
liftM2 (<>) (a r mgr) (b r mgr)
|
|
||||||
|
|
||||||
-- | A set of predicates. Construct one with 'mempty' and '<%>'.
|
-- | A set of predicates. Construct one with 'mempty' and '<%>'.
|
||||||
data Predicates = Predicates
|
data Predicates n r = Predicates
|
||||||
{ requestPredicates :: RequestPredicate
|
{ reqPreds :: RequestPredicate n r
|
||||||
, responsePredicates :: ResponsePredicate
|
, respPreds :: ResponsePredicate n r
|
||||||
} deriving (Generic)
|
} deriving (Generic, Functor)
|
||||||
|
|
||||||
instance Semigroup Predicates where
|
instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
|
||||||
a <> b = Predicates (requestPredicates a <> requestPredicates b)
|
|
||||||
(responsePredicates a <> responsePredicates b)
|
|
||||||
|
|
||||||
instance Monoid Predicates where
|
|
||||||
mempty = Predicates mempty mempty
|
mempty = Predicates mempty mempty
|
||||||
mappend = (<>)
|
a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
class JoinPreds a where
|
class JoinPreds a where
|
||||||
joinPreds :: a -> Predicates -> Predicates
|
joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
|
||||||
|
|
||||||
instance JoinPreds (RequestPredicate ) where
|
instance JoinPreds (RequestPredicate Text Bool) where
|
||||||
joinPreds p (Predicates x y) = Predicates (p <> x) y
|
joinPreds p (Predicates x y) = Predicates (go <> x) y
|
||||||
|
where go = let p' = first return p
|
||||||
|
in fmap (\z -> if z then [] else reqPredName p') p'
|
||||||
|
|
||||||
|
instance JoinPreds (ResponsePredicate Text Bool) where
|
||||||
|
joinPreds p (Predicates x y) = Predicates x (go <> y)
|
||||||
|
where go = let p' = first return p
|
||||||
|
in fmap (\z -> if z then [] else respPredName p') p'
|
||||||
|
|
||||||
instance JoinPreds (ResponsePredicate ) where
|
|
||||||
joinPreds p (Predicates x y) = Predicates x (p <> y)
|
|
||||||
|
|
||||||
-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
|
-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
|
||||||
-- the existing predicates.
|
-- the existing predicates.
|
||||||
@ -429,17 +357,14 @@ instance JoinPreds (ResponsePredicate ) where
|
|||||||
-- > not500 <%> onlyJsonObjects <%> empty
|
-- > not500 <%> onlyJsonObjects <%> empty
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
(<%>) :: JoinPreds a => a -> Predicates -> Predicates
|
(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
|
||||||
(<%>) = joinPreds
|
(<%>) = joinPreds
|
||||||
infixr 6 <%>
|
infixr 6 <%>
|
||||||
|
|
||||||
finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
|
finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
|
||||||
finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
|
finishPredicates p req mgr = do
|
||||||
where
|
(soFar, resps) <- reqResps (reqPreds p) req mgr
|
||||||
go = do
|
return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
|
||||||
resps <- getRequestPredicate (requestPredicates p) req mgr
|
|
||||||
mapM_ (getResponsePredicate $ responsePredicates p) resps
|
|
||||||
return Nothing
|
|
||||||
|
|
||||||
-- * helpers
|
-- * helpers
|
||||||
|
|
||||||
@ -448,14 +373,5 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
|
|||||||
Nothing -> False
|
Nothing -> False
|
||||||
Just v -> p v
|
Just v -> p v
|
||||||
|
|
||||||
isRFC822Date :: SBS.ByteString -> Bool
|
status2XX :: Response b -> Bool
|
||||||
isRFC822Date s
|
status2XX r = status200 <= responseStatus r && responseStatus r < status300
|
||||||
= case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of
|
|
||||||
Nothing -> False
|
|
||||||
Just (_ :: UTCTime) -> True
|
|
||||||
|
|
||||||
status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
|
|
||||||
status2XX mreq resp t
|
|
||||||
| status200 <= responseStatus resp && responseStatus resp < status300
|
|
||||||
= return ()
|
|
||||||
| otherwise = throw $ PredicateFailure t mreq resp
|
|
||||||
|
|||||||
@ -1,31 +1,25 @@
|
|||||||
{-# LANGUAGE RecordWildCards #-}
|
|
||||||
{-# LANGUAGE CPP #-}
|
|
||||||
module Servant.QuickCheck.Internal.QuickCheck where
|
module Servant.QuickCheck.Internal.QuickCheck where
|
||||||
|
|
||||||
import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
|
|
||||||
import Control.Monad (unless)
|
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import Data.Proxy (Proxy)
|
import Data.Proxy (Proxy)
|
||||||
import qualified Network.HTTP.Client as C
|
import Data.Text (Text)
|
||||||
|
import Network.HTTP.Client (Manager, Request, checkStatus,
|
||||||
|
defaultManagerSettings, httpLbs,
|
||||||
|
newManager)
|
||||||
import Network.Wai.Handler.Warp (withApplication)
|
import Network.Wai.Handler.Warp (withApplication)
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
import Servant (Context (EmptyContext), HasServer,
|
import Servant (Context (EmptyContext), HasServer,
|
||||||
Server, serveWithContext)
|
Server, serveWithContext)
|
||||||
#if MIN_VERSION_servant_server(0,18,0)
|
|
||||||
import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, type (.++))
|
|
||||||
#endif
|
|
||||||
import Servant.Client (BaseUrl (..), Scheme (..))
|
import Servant.Client (BaseUrl (..), Scheme (..))
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
import Test.Hspec (Expectation, expectationFailure)
|
import Test.Hspec (Expectation, expectationFailure)
|
||||||
import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)
|
import Test.QuickCheck (Args (..), Result (..),
|
||||||
import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
|
quickCheckWithResult)
|
||||||
run)
|
import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)
|
||||||
import Test.QuickCheck.Property (counterexample)
|
|
||||||
|
|
||||||
import Servant.QuickCheck.Internal.Equality
|
|
||||||
import Servant.QuickCheck.Internal.ErrorTypes
|
|
||||||
import Servant.QuickCheck.Internal.HasGenRequest
|
import Servant.QuickCheck.Internal.HasGenRequest
|
||||||
import Servant.QuickCheck.Internal.Predicates
|
import Servant.QuickCheck.Internal.Predicates
|
||||||
|
import Servant.QuickCheck.Internal.Equality
|
||||||
|
|
||||||
|
|
||||||
-- | Start a servant application on an open port, run the provided function,
|
-- | Start a servant application on an open port, run the provided function,
|
||||||
@ -40,11 +34,7 @@ withServantServer api = withServantServerAndContext api EmptyContext
|
|||||||
-- application.
|
-- application.
|
||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
#if MIN_VERSION_servant_server(0,18,0)
|
|
||||||
withServantServerAndContext :: (HasServer a ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters)
|
|
||||||
#else
|
|
||||||
withServantServerAndContext :: HasServer a ctx
|
withServantServerAndContext :: HasServer a ctx
|
||||||
#endif
|
|
||||||
=> Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
|
=> Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
|
||||||
withServantServerAndContext api ctx server t
|
withServantServerAndContext api ctx server t
|
||||||
= withApplication (return . serveWithContext api ctx =<< server) $ \port ->
|
= withApplication (return . serveWithContext api ctx =<< server) $ \port ->
|
||||||
@ -62,47 +52,21 @@ withServantServerAndContext api ctx server t
|
|||||||
-- Evidently, if the behaviour of the server is expected to be
|
-- Evidently, if the behaviour of the server is expected to be
|
||||||
-- non-deterministic, this function may produce spurious failures
|
-- non-deterministic, this function may produce spurious failures
|
||||||
--
|
--
|
||||||
-- Note that only valid requests are generated and tested. As an example of why
|
|
||||||
-- this matters, let's say your API specifies that a particular endpoint can
|
|
||||||
-- only generate @JSON@. @serversEqual@ will then not generate any requests
|
|
||||||
-- with an @Accept@ header _other_ than @application/json@. It may therefore
|
|
||||||
-- fail to notice that one application, when the request has @Accept:
|
|
||||||
-- text/html@, returns a @406 Not Acceptable@ HTTP response, and another
|
|
||||||
-- returns a @200 Success@, but with @application/json@ as the content-type.
|
|
||||||
--
|
|
||||||
-- The fact that only valid requests are tested also means that no endpoints
|
|
||||||
-- not listed in the API type are tested.
|
|
||||||
--
|
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
serversEqual :: HasGenRequest a =>
|
serversEqual :: HasGenRequest a =>
|
||||||
Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
|
Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
|
||||||
serversEqual api burl1 burl2 args req = do
|
serversEqual api burl1 burl2 args req = do
|
||||||
let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
|
let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
|
||||||
-- This MVar stuff is clunky! But there doesn't seem to be an easy way to
|
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
|
||||||
-- return results when a test fails, since an exception is throw.
|
resp1 <- run $ httpLbs (noCheckStatus req1) defManager
|
||||||
deetsMVar <- newEmptyMVar
|
resp2 <- run $ httpLbs (noCheckStatus req2) defManager
|
||||||
r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
|
assert $ getResponseEquality req resp1 resp2
|
||||||
resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
|
|
||||||
resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
|
|
||||||
unless (getResponseEquality req resp1 resp2) $ do
|
|
||||||
monitor (counterexample "hi" )
|
|
||||||
_ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
|
|
||||||
assert False
|
|
||||||
case r of
|
case r of
|
||||||
Success {} -> return ()
|
Success {} -> return ()
|
||||||
Failure{..} -> do
|
|
||||||
mx <- tryReadMVar deetsMVar
|
|
||||||
case mx of
|
|
||||||
Just x ->
|
|
||||||
expectationFailure $ "Failed:\n" ++ show x
|
|
||||||
Nothing ->
|
|
||||||
expectationFailure $ "We failed to record a reason for failure: " <> show r
|
|
||||||
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
||||||
NoExpectedFailure {} -> expectationFailure "No expected failure"
|
Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
|
||||||
#if MIN_VERSION_QuickCheck(2,12,0)
|
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
||||||
#else
|
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
|
||||||
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
|
|
||||||
#endif
|
|
||||||
|
|
||||||
-- | Check that a server satisfies the set of properties specified.
|
-- | Check that a server satisfies the set of properties specified.
|
||||||
--
|
--
|
||||||
@ -124,70 +88,37 @@ serversEqual api burl1 burl2 args req = do
|
|||||||
--
|
--
|
||||||
-- /Since 0.0.0.0/
|
-- /Since 0.0.0.0/
|
||||||
serverSatisfies :: (HasGenRequest a) =>
|
serverSatisfies :: (HasGenRequest a) =>
|
||||||
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
|
Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
|
||||||
serverSatisfies api = serverSatisfiesMgr api defManager
|
serverSatisfies api burl args preds = do
|
||||||
|
let reqs = ($ burl) <$> genRequest api
|
||||||
-- | Check that a server satisfies the set of properties specified, and
|
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
|
||||||
-- accept a 'Manager' for running the HTTP requests through.
|
v <- run $ finishPredicates preds (noCheckStatus req) defManager
|
||||||
--
|
assert $ null v
|
||||||
-- See 'serverSatisfies' for more details.
|
|
||||||
--
|
|
||||||
-- @since 0.0.7.2
|
|
||||||
serverSatisfiesMgr :: (HasGenRequest a) =>
|
|
||||||
Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
|
|
||||||
serverSatisfiesMgr api manager burl args preds = do
|
|
||||||
let reqs = ($ burl) <$> runGenRequest api
|
|
||||||
deetsMVar <- newEmptyMVar
|
|
||||||
r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
|
|
||||||
v <- run $ finishPredicates preds (noCheckStatus req) manager
|
|
||||||
_ <- run $ tryPutMVar deetsMVar v
|
|
||||||
case v of
|
|
||||||
Just _ -> assert False
|
|
||||||
_ -> return ()
|
|
||||||
case r of
|
case r of
|
||||||
Success {} -> return ()
|
Success {} -> return ()
|
||||||
Failure {..} -> do
|
|
||||||
mx <- tryReadMVar deetsMVar
|
|
||||||
case mx of
|
|
||||||
Just x ->
|
|
||||||
expectationFailure $ "Failed:\n" ++ show x
|
|
||||||
Nothing ->
|
|
||||||
expectationFailure $ "We failed to record a reason for failure: " <> show r
|
|
||||||
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
||||||
|
Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
|
||||||
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
||||||
#if MIN_VERSION_QuickCheck(2,12,0)
|
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
|
||||||
#else
|
|
||||||
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
|
|
||||||
#endif
|
|
||||||
|
|
||||||
serverDoesntSatisfy :: (HasGenRequest a) =>
|
serverDoesntSatisfy :: (HasGenRequest a) =>
|
||||||
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
|
Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
|
||||||
serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
|
serverDoesntSatisfy api burl args preds = do
|
||||||
|
let reqs = ($ burl) <$> genRequest api
|
||||||
serverDoesntSatisfyMgr :: (HasGenRequest a) =>
|
|
||||||
Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
|
|
||||||
serverDoesntSatisfyMgr api manager burl args preds = do
|
|
||||||
let reqs = ($ burl) <$> runGenRequest api
|
|
||||||
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
|
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
|
||||||
v <- run $ finishPredicates preds (noCheckStatus req) manager
|
v <- run $ finishPredicates preds (noCheckStatus req) defManager
|
||||||
assert $ not $ null v
|
assert $ not $ null v
|
||||||
case r of
|
case r of
|
||||||
Success {} -> return ()
|
Success {} -> return ()
|
||||||
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
|
||||||
Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
|
Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
|
||||||
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
|
||||||
#if MIN_VERSION_QuickCheck(2,12,0)
|
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
|
||||||
#else
|
|
||||||
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
|
|
||||||
#endif
|
|
||||||
|
|
||||||
noCheckStatus :: C.Request -> C.Request
|
noCheckStatus :: Request -> Request
|
||||||
#if MIN_VERSION_http_client(0,5,0)
|
noCheckStatus r = r { checkStatus = \_ _ _ -> Nothing}
|
||||||
noCheckStatus = id
|
|
||||||
#else
|
|
||||||
noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
defManager :: C.Manager
|
defManager :: Manager
|
||||||
defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
defManager = unsafePerformIO $ newManager defaultManagerSettings
|
||||||
{-# NOINLINE defManager #-}
|
{-# NOINLINE defManager #-}
|
||||||
|
|||||||
36
stack.yaml
36
stack.yaml
@ -1,10 +1,36 @@
|
|||||||
resolver: nightly-2018-09-03
|
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
|
||||||
|
resolver: nightly-2016-04-20
|
||||||
|
|
||||||
|
# Local packages, usually specified by relative directory name
|
||||||
packages:
|
packages:
|
||||||
- '.'
|
- '.'
|
||||||
|
|
||||||
|
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
|
||||||
extra-deps:
|
extra-deps:
|
||||||
- hspec-discover-2.5.6
|
- servant-0.7
|
||||||
- hspec-core-2.5.6
|
- servant-client-0.7
|
||||||
- hspec-2.5.6
|
- servant-server-0.7
|
||||||
- QuickCheck-2.12
|
|
||||||
|
# Override default flag values for local packages and extra-deps
|
||||||
flags: {}
|
flags: {}
|
||||||
|
|
||||||
|
# Extra package databases containing global packages
|
||||||
extra-package-dbs: []
|
extra-package-dbs: []
|
||||||
|
|
||||||
|
# Control whether we use the GHC we find on the path
|
||||||
|
# system-ghc: true
|
||||||
|
|
||||||
|
# Require a specific version of stack, using version ranges
|
||||||
|
# require-stack-version: -any # Default
|
||||||
|
# require-stack-version: >= 1.0.0
|
||||||
|
|
||||||
|
# Override the architecture used by stack, especially useful on Windows
|
||||||
|
# arch: i386
|
||||||
|
# arch: x86_64
|
||||||
|
|
||||||
|
# Extra directories used by stack for building
|
||||||
|
# extra-include-dirs: [/path/to/dir]
|
||||||
|
# extra-lib-dirs: [/path/to/dir]
|
||||||
|
|
||||||
|
# Allow a newer minor version of GHC than the snapshot specifies
|
||||||
|
# compiler-check: newer-minor
|
||||||
|
|||||||
44
test/Doctest.hs
Normal file
44
test/Doctest.hs
Normal file
@ -0,0 +1,44 @@
|
|||||||
|
module Main where
|
||||||
|
|
||||||
|
import Data.List (isPrefixOf)
|
||||||
|
import System.Directory
|
||||||
|
import System.FilePath
|
||||||
|
import System.FilePath.Find
|
||||||
|
import Test.DocTest
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
files <- find always (extension ==? ".hs") "src"
|
||||||
|
mCabalMacrosFile <- getCabalMacrosFile
|
||||||
|
doctest $ "-isrc" : "-Iinclude" :
|
||||||
|
(maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
|
||||||
|
"-XOverloadedStrings" :
|
||||||
|
"-XDeriveFunctor" :
|
||||||
|
"-XFlexibleInstances" :
|
||||||
|
"-XFlexibleContexts" :
|
||||||
|
"-XMultiParamTypeClasses" :
|
||||||
|
"-XDataKinds" :
|
||||||
|
"-XTypeOperators" :
|
||||||
|
"-XGADTs" :
|
||||||
|
files
|
||||||
|
|
||||||
|
getCabalMacrosFile :: IO (Maybe FilePath)
|
||||||
|
getCabalMacrosFile = do
|
||||||
|
exists <- doesDirectoryExist "dist"
|
||||||
|
if exists
|
||||||
|
then do
|
||||||
|
contents <- getDirectoryContents "dist"
|
||||||
|
let rest = "build" </> "autogen" </> "cabal_macros.h"
|
||||||
|
whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
|
||||||
|
[x] -> "dist" </> x </> rest
|
||||||
|
[] -> "dist" </> rest
|
||||||
|
xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
|
||||||
|
++ show xs ++ "\nTry cabal clean"
|
||||||
|
else return Nothing
|
||||||
|
where
|
||||||
|
whenExists :: FilePath -> IO (Maybe FilePath)
|
||||||
|
whenExists file = do
|
||||||
|
exists <- doesFileExist file
|
||||||
|
return $ if exists
|
||||||
|
then Just file
|
||||||
|
else Nothing
|
||||||
@ -1,46 +1,24 @@
|
|||||||
{-# LANGUAGE CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
module Servant.QuickCheck.InternalSpec (spec) where
|
module Servant.QuickCheck.InternalSpec (spec) where
|
||||||
|
|
||||||
|
import Control.Concurrent.MVar (newMVar, readMVar,
|
||||||
import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
|
swapMVar)
|
||||||
import Control.Exception (SomeException)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Monad (replicateM)
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
import qualified Data.ByteString as BS
|
|
||||||
import qualified Data.ByteString.Char8 as C
|
|
||||||
import Data.Maybe (fromJust)
|
|
||||||
import Network.HTTP.Client (path, queryString)
|
|
||||||
import Prelude.Compat
|
import Prelude.Compat
|
||||||
import Servant
|
import Servant
|
||||||
import Servant.HTML.Blaze (HTML)
|
import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
|
||||||
import qualified Text.Blaze.Html as Blaze
|
import Test.Hspec (Spec, describe, it,
|
||||||
import qualified Text.Blaze.Html5 as Blaze5
|
shouldBe)
|
||||||
import Test.Hspec (Spec, context, describe, it, shouldBe,
|
|
||||||
shouldContain)
|
|
||||||
import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
|
|
||||||
defaultParams, safeEvaluateExample)
|
|
||||||
import Test.QuickCheck.Gen (generate, unGen)
|
|
||||||
import Test.QuickCheck.Random (mkQCGen)
|
|
||||||
|
|
||||||
|
import Servant.QuickCheck
|
||||||
import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
|
import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
|
||||||
|
|
||||||
import Servant.QuickCheck
|
|
||||||
import Servant.QuickCheck.Internal (genRequest, runGenRequest,
|
|
||||||
serverDoesntSatisfy)
|
|
||||||
|
|
||||||
spec :: Spec
|
spec :: Spec
|
||||||
spec = do
|
spec = do
|
||||||
serversEqualSpec
|
serversEqualSpec
|
||||||
serverSatisfiesSpec
|
serverSatisfiesSpec
|
||||||
isComprehensiveSpec
|
isComprehensiveSpec
|
||||||
onlyJsonObjectSpec
|
|
||||||
notLongerThanSpec
|
|
||||||
queryParamsSpec
|
|
||||||
queryFlagsSpec
|
|
||||||
deepPathSpec
|
|
||||||
htmlDocTypesSpec
|
|
||||||
unbiasedGenerationSpec
|
|
||||||
|
|
||||||
serversEqualSpec :: Spec
|
serversEqualSpec :: Spec
|
||||||
serversEqualSpec = describe "serversEqual" $ do
|
serversEqualSpec = describe "serversEqual" $ do
|
||||||
@ -50,43 +28,6 @@ serversEqualSpec = describe "serversEqual" $ do
|
|||||||
withServantServerAndContext api ctx server $ \burl2 -> do
|
withServantServerAndContext api ctx server $ \burl2 -> do
|
||||||
serversEqual api burl1 burl2 args bodyEquality
|
serversEqual api burl1 burl2 args bodyEquality
|
||||||
|
|
||||||
context "when servers are not equal" $ do
|
|
||||||
it "provides the failing responses in the error message" $ do
|
|
||||||
FailedWith err <- withServantServer api2 server2 $ \burl1 ->
|
|
||||||
withServantServer api2 server3 $ \burl2 -> do
|
|
||||||
evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
|
|
||||||
show err `shouldContain` "Server equality failed"
|
|
||||||
show err `shouldContain` "Body: 1"
|
|
||||||
show err `shouldContain` "Body: 2"
|
|
||||||
show err `shouldContain` "Path: /failplz"
|
|
||||||
|
|
||||||
context "when JSON is equal but looks a bit different as a ByteString" $ do
|
|
||||||
|
|
||||||
it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
|
|
||||||
FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
|
|
||||||
withServantServer jsonApi jsonServer2 $ \burl2 -> do
|
|
||||||
evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
|
|
||||||
show err `shouldContain` "Server equality failed"
|
|
||||||
|
|
||||||
it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
|
|
||||||
withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
|
|
||||||
withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
|
|
||||||
serversEqual jsonApi burl1 burl2 args jsonEquality
|
|
||||||
|
|
||||||
it "sees when JSON apis are not equal because any value is different" $ do
|
|
||||||
FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
|
|
||||||
withServantServer jsonApi jsonServer3 $ \burl2 -> do
|
|
||||||
evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
|
|
||||||
show err `shouldContain` "Server equality failed"
|
|
||||||
show err `shouldContain` "Path: /jsonComparison"
|
|
||||||
|
|
||||||
it "sees when JSON apis are not equal due to different keys but same values" $ do
|
|
||||||
FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
|
|
||||||
withServantServer jsonApi jsonServer4 $ \burl2 -> do
|
|
||||||
evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
|
|
||||||
show err `shouldContain` "Server equality failed"
|
|
||||||
show err `shouldContain` "Path: /jsonComparison"
|
|
||||||
|
|
||||||
|
|
||||||
serverSatisfiesSpec :: Spec
|
serverSatisfiesSpec :: Spec
|
||||||
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
serverSatisfiesSpec = describe "serverSatisfies" $ do
|
||||||
@ -105,126 +46,13 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
|
|||||||
<%> notAllowedContainsAllowHeader
|
<%> notAllowedContainsAllowHeader
|
||||||
<%> mempty)
|
<%> mempty)
|
||||||
|
|
||||||
context "when predicates are false" $ do
|
|
||||||
|
|
||||||
it "fails with informative error messages" $ do
|
|
||||||
FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
|
|
||||||
evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
|
|
||||||
show err `shouldContain` "notAllowedContainsAllowHeader"
|
|
||||||
show err `shouldContain` "Headers"
|
|
||||||
show err `shouldContain` "Body"
|
|
||||||
|
|
||||||
|
|
||||||
onlyJsonObjectSpec :: Spec
|
|
||||||
onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
|
|
||||||
|
|
||||||
it "fails correctly" $ do
|
|
||||||
FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
|
|
||||||
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
|
|
||||||
(onlyJsonObjects <%> mempty)
|
|
||||||
show err `shouldContain` "onlyJsonObjects"
|
|
||||||
|
|
||||||
it "accepts non-JSON endpoints" $ do
|
|
||||||
withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
|
|
||||||
serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
|
|
||||||
|
|
||||||
it "does not fail when there is no content-type" $ do
|
|
||||||
withServantServerAndContext api2 ctx serverFailing $ \burl ->
|
|
||||||
serverSatisfies api2 burl args (onlyJsonObjects <%> mempty)
|
|
||||||
|
|
||||||
notLongerThanSpec :: Spec
|
|
||||||
notLongerThanSpec = describe "notLongerThan" $ do
|
|
||||||
|
|
||||||
it "fails correctly" $ do
|
|
||||||
FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
|
|
||||||
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
|
|
||||||
(notLongerThan 1 <%> mempty)
|
|
||||||
show err `shouldContain` "notLongerThan"
|
|
||||||
|
|
||||||
it "succeeds correctly" $ do
|
|
||||||
withServantServerAndContext api ctx server $ \burl ->
|
|
||||||
serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)
|
|
||||||
|
|
||||||
isComprehensiveSpec :: Spec
|
isComprehensiveSpec :: Spec
|
||||||
isComprehensiveSpec = describe "HasGenRequest" $ do
|
isComprehensiveSpec = describe "HasGenRequest" $ do
|
||||||
|
|
||||||
it "has instances for all 'servant' combinators" $ do
|
it "has instances for all 'servant' combinators" $ do
|
||||||
let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
|
let _g = genRequest comprehensiveAPI
|
||||||
True `shouldBe` True -- This is a type-level check
|
True `shouldBe` True -- This is a type-level check
|
||||||
|
|
||||||
deepPathSpec :: Spec
|
|
||||||
deepPathSpec = describe "Path components" $ do
|
|
||||||
|
|
||||||
it "are separated by slashes, without a trailing slash" $ do
|
|
||||||
let rng = mkQCGen 0
|
|
||||||
burl = BaseUrl Http "localhost" 80 ""
|
|
||||||
gen = runGenRequest deepAPI
|
|
||||||
req = (unGen gen rng 0) burl
|
|
||||||
path req `shouldBe` ("/one/two/three")
|
|
||||||
|
|
||||||
|
|
||||||
queryParamsSpec :: Spec
|
|
||||||
queryParamsSpec = describe "QueryParams" $ do
|
|
||||||
|
|
||||||
it "reduce to an HTTP query string correctly" $ do
|
|
||||||
let rng = mkQCGen 0
|
|
||||||
burl = BaseUrl Http "localhost" 80 ""
|
|
||||||
gen = runGenRequest paramsAPI
|
|
||||||
req = (unGen gen rng 0) burl
|
|
||||||
qs = C.unpack $ queryString req
|
|
||||||
qs `shouldBe` "one=_&two=_"
|
|
||||||
|
|
||||||
queryFlagsSpec :: Spec
|
|
||||||
queryFlagsSpec = describe "QueryFlags" $ do
|
|
||||||
|
|
||||||
it "reduce to an HTTP query string correctly" $ do
|
|
||||||
let rng = mkQCGen 0
|
|
||||||
burl = BaseUrl Http "localhost" 80 ""
|
|
||||||
gen = runGenRequest flagsAPI
|
|
||||||
req = (unGen gen rng 0) burl
|
|
||||||
qs = C.unpack $ queryString req
|
|
||||||
qs `shouldBe` "one&two"
|
|
||||||
|
|
||||||
htmlDocTypesSpec :: Spec
|
|
||||||
htmlDocTypesSpec = describe "HtmlDocTypes" $ do
|
|
||||||
|
|
||||||
it "fails HTML without doctype correctly" $ do
|
|
||||||
err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
|
|
||||||
evalExample $ serverSatisfies docTypeApi burl args
|
|
||||||
(htmlIncludesDoctype <%> mempty)
|
|
||||||
show err `shouldContain` "htmlIncludesDoctype"
|
|
||||||
|
|
||||||
it "passes HTML with a doctype at start" $ do
|
|
||||||
withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
|
|
||||||
serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
|
|
||||||
|
|
||||||
it "accepts json endpoints and passes over them in silence" $ do
|
|
||||||
withServantServerAndContext api ctx server $ \burl -> do
|
|
||||||
serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
|
|
||||||
(htmlIncludesDoctype <%> mempty)
|
|
||||||
|
|
||||||
|
|
||||||
makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
|
|
||||||
makeRandomRequest large burl = do
|
|
||||||
req <- generate $ runGenRequest large
|
|
||||||
pure $ fst . fromJust . C.readInteger . C.drop 1 . path $ req burl
|
|
||||||
|
|
||||||
|
|
||||||
unbiasedGenerationSpec :: Spec
|
|
||||||
unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
|
|
||||||
|
|
||||||
it "frequency paired with generated endpoint should be more randomly distributed" $ do
|
|
||||||
let burl = BaseUrl Http "localhost" 80 ""
|
|
||||||
let runs = 10000 :: Double
|
|
||||||
someRequests <- replicateM 10000 (makeRandomRequest largeApi burl)
|
|
||||||
let mean = (sum $ map fromIntegral someRequests) / runs
|
|
||||||
let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
|
|
||||||
let variance = (sum $ map variancer someRequests) / runs - 1
|
|
||||||
-- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
|
|
||||||
mean > 8 `shouldBe` True
|
|
||||||
mean < 9 `shouldBe` True
|
|
||||||
-- Std dev is likely around 4. Variance is probably greater than 20.
|
|
||||||
variance > 19.5 `shouldBe` True
|
|
||||||
|
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- APIs
|
-- APIs
|
||||||
@ -237,17 +65,6 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String
|
|||||||
api :: Proxy API
|
api :: Proxy API
|
||||||
api = Proxy
|
api = Proxy
|
||||||
|
|
||||||
type ParamsAPI = QueryParam "one" () :> QueryParam "two" () :> Get '[JSON] ()
|
|
||||||
|
|
||||||
paramsAPI :: Proxy ParamsAPI
|
|
||||||
paramsAPI = Proxy
|
|
||||||
|
|
||||||
type FlagsAPI = QueryFlag "one" :> QueryFlag "two" :> Get '[JSON] ()
|
|
||||||
|
|
||||||
flagsAPI :: Proxy FlagsAPI
|
|
||||||
flagsAPI = Proxy
|
|
||||||
|
|
||||||
|
|
||||||
server :: IO (Server API)
|
server :: IO (Server API)
|
||||||
server = do
|
server = do
|
||||||
mvar <- newMVar ""
|
mvar <- newMVar ""
|
||||||
@ -255,110 +72,11 @@ server = do
|
|||||||
:<|> (liftIO $ readMVar mvar >>= return . length)
|
:<|> (liftIO $ readMVar mvar >>= return . length)
|
||||||
:<|> (const $ return ())
|
:<|> (const $ return ())
|
||||||
|
|
||||||
|
|
||||||
type API2 = "failplz" :> Get '[JSON] Int
|
|
||||||
|
|
||||||
api2 :: Proxy API2
|
|
||||||
api2 = Proxy
|
|
||||||
|
|
||||||
type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
|
|
||||||
|
|
||||||
deepAPI :: Proxy DeepAPI
|
|
||||||
deepAPI = Proxy
|
|
||||||
|
|
||||||
|
|
||||||
server2 :: IO (Server API2)
|
|
||||||
server2 = return $ return 1
|
|
||||||
|
|
||||||
server3 :: IO (Server API2)
|
|
||||||
server3 = return $ return 2
|
|
||||||
|
|
||||||
serverFailing :: IO (Server API2)
|
|
||||||
serverFailing = return . throwError $ err405
|
|
||||||
|
|
||||||
-- With Doctypes
|
|
||||||
type HtmlDoctype = Get '[HTML] Blaze.Html
|
|
||||||
|
|
||||||
docTypeApi :: Proxy HtmlDoctype
|
|
||||||
docTypeApi = Proxy
|
|
||||||
|
|
||||||
docTypeServer :: IO (Server HtmlDoctype)
|
|
||||||
docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
|
|
||||||
|
|
||||||
noDocTypeServer :: IO (Server HtmlDoctype)
|
|
||||||
noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
|
|
||||||
|
|
||||||
|
|
||||||
-- Api for unbiased generation of requests tests
|
|
||||||
largeApi :: Proxy LargeAPI
|
|
||||||
largeApi = Proxy
|
|
||||||
|
|
||||||
type LargeAPI
|
|
||||||
= "1" :> Get '[JSON] Int
|
|
||||||
:<|> "2" :> Get '[JSON] Int
|
|
||||||
:<|> "3" :> Get '[JSON] Int
|
|
||||||
:<|> "4" :> Get '[JSON] Int
|
|
||||||
:<|> "5" :> Get '[JSON] Int
|
|
||||||
:<|> "6" :> Get '[JSON] Int
|
|
||||||
:<|> "7" :> Get '[JSON] Int
|
|
||||||
:<|> "8" :> Get '[JSON] Int
|
|
||||||
:<|> "9" :> Get '[JSON] Int
|
|
||||||
:<|> "10" :> Get '[JSON] Int
|
|
||||||
:<|> "11" :> Get '[JSON] Int
|
|
||||||
:<|> "12" :> Get '[JSON] Int
|
|
||||||
:<|> "13" :> Get '[JSON] Int
|
|
||||||
:<|> "14" :> Get '[JSON] Int
|
|
||||||
:<|> "15" :> Get '[JSON] Int
|
|
||||||
:<|> "16" :> Get '[JSON] Int
|
|
||||||
|
|
||||||
|
|
||||||
type OctetAPI = Get '[OctetStream] BS.ByteString
|
|
||||||
|
|
||||||
octetAPI :: Proxy OctetAPI
|
|
||||||
octetAPI = Proxy
|
|
||||||
|
|
||||||
serverOctetAPI :: IO (Server OctetAPI)
|
|
||||||
serverOctetAPI = return $ return "blah"
|
|
||||||
|
|
||||||
type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString
|
|
||||||
|
|
||||||
jsonApi :: Proxy JsonApi
|
|
||||||
jsonApi = Proxy
|
|
||||||
|
|
||||||
jsonServer1 :: IO (Server JsonApi)
|
|
||||||
jsonServer1 = return $ return "{ \"b\": [\"b\"], \"a\": 1 }" -- whitespace, ordering different
|
|
||||||
|
|
||||||
jsonServer2 :: IO (Server JsonApi)
|
|
||||||
jsonServer2 = return $ return "{\"a\": 1,\"b\":[\"b\"]}"
|
|
||||||
|
|
||||||
jsonServer3 :: IO (Server JsonApi)
|
|
||||||
jsonServer3 = return $ return "{\"a\": 2, \"b\": [\"b\"]}"
|
|
||||||
|
|
||||||
jsonServer4 :: IO (Server JsonApi)
|
|
||||||
jsonServer4 = return $ return "{\"c\": 1, \"d\": [\"b\"]}"
|
|
||||||
|
|
||||||
|
|
||||||
ctx :: Context '[BasicAuthCheck ()]
|
ctx :: Context '[BasicAuthCheck ()]
|
||||||
ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
|
ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
-- Utils
|
-- Utils
|
||||||
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
||||||
evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
|
|
||||||
evalExample e = do
|
|
||||||
r <- safeEvaluateExample e defaultParams ($ ()) progCallback
|
|
||||||
case resultStatus r of
|
|
||||||
Success -> return $ AllGood
|
|
||||||
Failure _ reason -> return $ FailedWith $ show reason
|
|
||||||
Pending {} -> error "should not happen"
|
|
||||||
where
|
|
||||||
progCallback _ = return ()
|
|
||||||
|
|
||||||
data EvalResult
|
|
||||||
= AnException SomeException
|
|
||||||
| AllGood
|
|
||||||
| FailedWith String
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
|
|
||||||
args :: Args
|
args :: Args
|
||||||
args = defaultArgs { maxSuccess = noOfTestCases }
|
args = defaultArgs { maxSuccess = noOfTestCases }
|
||||||
@ -367,5 +85,5 @@ noOfTestCases :: Int
|
|||||||
#if LONG_TESTS
|
#if LONG_TESTS
|
||||||
noOfTestCases = 20000
|
noOfTestCases = 20000
|
||||||
#else
|
#else
|
||||||
noOfTestCases = 1000
|
noOfTestCases = 500
|
||||||
#endif
|
#endif
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user