git.iko.soy/servant-quickcheck
on f36f544 help sign in
0535413
swap
0 ahead, 94 behind
.travis.yml+21−153
since splitsnapshots
unifiedsplit
@@ -1,158 +1,26 @@
1−# This Travis job script has been generated by a script via
1+sudo: false
2−#
2+
3−# haskell-ci '--config=cabal.haskell-ci' 'servant-quickcheck.cabal'
4−#
5−# To regenerate the script (for example after adjusting tested-with) run
6−#
7−# haskell-ci regenerate
8−#
9−# For more information, see https://github.com/haskell-CI/haskell-ci
10−#
11−# version: 0.10.1
12−#
13−version: ~> 1.0
14language: c
3language: c
15−os: linux
4+
16−dist: xenial
5+matrix:
17−git:
18− # whether to recursively clone submodules
19− submodules: false
20−branches:
21− only:
22− - master
23−cache:
24− directories:
25− - $HOME/.cabal/packages
26− - $HOME/.cabal/store
27− - $HOME/.hlint
28−before_cache:
29− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
30− # remove files that are regenerated by 'cabal update'
31− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
32− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
33− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
34− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
35− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
36− - rm -rfv $CABALHOME/packages/head.hackage
37−jobs:
38 include:
6 include:
39− - compiler: ghc-8.8.3
7+ - env: CABALVER=1.22 GHCVER=7.10.1
40− 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"]}}
8+ addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1],sources: [hvr-ghc]}}
41− os: linux
9+ - env: CABALVER=1.24 GHCVER=8.0.1
42− - compiler: ghc-8.6.5
10+ addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
43− 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"]}}
11+
44− os: linux
45− - compiler: ghc-8.4.4
46− 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"]}}
47− os: linux
48− - compiler: ghc-8.2.2
49− 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"]}}
50− os: linux
51− - compiler: ghc-8.0.2
52− 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"]}}
53− os: linux
54−before_install:
55− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
56− - WITHCOMPILER="-w $HC"
57− - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
58− - HCPKG="$HC-pkg"
59− - unset CC
60− - CABAL=/opt/ghc/bin/cabal
61− - CABALHOME=$HOME/.cabal
62− - export PATH="$CABALHOME/bin:$PATH"
63− - TOP=$(pwd)
64− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
65− - echo $HCNUMVER
66− - CABAL="$CABAL -vnormal+nowrap"
67− - set -o pipefail
68− - TEST=--enable-tests
69− - BENCH=--enable-benchmarks
70− - HEADHACKAGE=false
71− - rm -f $CABALHOME/config
72− - |
73− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
74− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
75− echo "write-ghc-environment-files: always" >> $CABALHOME/config
76− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
77− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
78− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
79− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
80− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
81− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
82− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
83− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
84− echo "install-dirs user" >> $CABALHOME/config
85− echo " prefix: $CABALHOME" >> $CABALHOME/config
86− echo "repository hackage.haskell.org" >> $CABALHOME/config
87− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
88install:
12install:
89− - ${CABAL} --version
13+ - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
90− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
14+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
91− - |
15+ - ghc --version
92− echo "program-default-options" >> $CABALHOME/config
16+ - cabal --version
93− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
94− - cat $CABALHOME/config
95− - rm -fv cabal.project cabal.project.local cabal.project.freeze
96− - travis_retry ${CABAL} v2-update -v
17+ - travis_retry cabal update
97− # Generate cabal.project
18+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
98− - rm -rf cabal.project cabal.project.local cabal.project.freeze
19+
99− - touch cabal.project
100− - |
101− echo "packages: ." >> cabal.project
102− - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi
103− - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
104− - |
105− - "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"
106− - cat cabal.project || true
107− - cat cabal.project.local || true
108− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
109− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
110− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
111− - rm cabal.project.freeze
112− - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all
113− - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all
114script:
20script:
115− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
21+ - tinc && cabal configure --enable-tests && cabal build && cabal test
116− # Packaging...
22+ - cabal check
117− - ${CABAL} v2-sdist all
118− # Unpacking...
119− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
120− - cd ${DISTDIR} || false
121− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
122− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
123− - PKGDIR_servant_quickcheck="$(find . -maxdepth 1 -type d -regex '.*/servant-quickcheck-[0-9.]*')"
124− # Generate cabal.project
125− - rm -rf cabal.project cabal.project.local cabal.project.freeze
126− - touch cabal.project
127− - |
128− echo "packages: ${PKGDIR_servant_quickcheck}" >> cabal.project
129− - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi
130− - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
131− - |
132− - "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"
133− - cat cabal.project || true
134− - cat cabal.project.local || true
135− # Building...
136− # this builds all libraries and executables (without tests/benchmarks)
137− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
138− # Building with tests and benchmarks...
139− # build & run tests, build benchmarks
140− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
141− # Testing...
142− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all
143− # cabal check...
144− - (cd ${PKGDIR_servant_quickcheck} && ${CABAL} -vnormal check)
145− # haddock...
146− - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all
147− # Building without installed constraints for packages in global-db...
148− - rm -f cabal.project.local
149− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
150− # Constraint sets
151− - rm -rf cabal.project.local
152− # Constraint set base-compat-0.10
153− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.10.*' all
154− # Constraint set base-compat-0.11
155− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.11.*' all
156
23
157−# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","servant-quickcheck.cabal"])
24+cache:
158−# EOF
25+ directories:
26+ - $HOME/.tinc/cache
CHANGELOG.yaml+2−170
@@ -1,174 +1,6 @@
1−releases:
1+upcoming:
2− - version: "0.0.9.0"
3− changes:
4− - description: "Support servant-0.15 (#65)"
5− authors: fizruk
6− date: 2020-06-25
7−
8− - description: "Relax constraints for GHC 8.10 (#70)"
9− authors: felixmulder
10− date: 2020-06-20
11−
12− - version: "0.0.8.0"
13− changes:
14− - description: Support for servant-0.17
15− authors: phadej
16− date: 2019-01-23
17−
18− - version: "0.0.7.3"
19− changes:
20− - description: Support for servant-0.14
21− issue: 53
22− authors: phadej
23− date: 2018-06-12
24−
25− - description: Fix a failure from OnlyJsonObjects when there is no content-type.
26− issue: 55
27− authors: Phenitei
28− date: 2018-08-27
29−
30− - description: A bug fix where notAllowedContainsAllowHeader would print the initial request alongside the failure instead of the request causing the failure when it failed.
31− issue: 57
32− authors: Phenitei
33− date: 2018-08-29
34−
35− - description: QuickCheck 2.12 compatibility
36− issue: 58
37− authors: parsonsmatt
38− date: 2018-10-12
39−
40− - description: GHC 8.6 compatibility
41− issue: 59
42− authors: phadej
43− date: 2018-10-15
44−
45− - version: "0.0.7.2"
46− changes:
47−
48− - description: Allow client to pass an HTTP Manager in to functions
49− issue: 47
50− authors: parsonsmatt
51− date: 2018-05-10
52−
53− - description: Fix "should not happen" error when exceptions are thrown
54− issue: 48
55− authors: parsonsmatt
56− date: 2018-05-10
57−
58− - version: "0.0.7.0"
59− changes:
60−
61− - description: Support for base-compat-0.10
62− issue: none
63− authors: phadej
64− date: 2018-04-12
65−
66− - version: "0.0.7.0"
67− changes:
68−
69− - description: Support for GHC-8.4.1
70− issue: none
71− authors: phadej
72− date: 2018-03-23
73−
74− - description: Requires hspec-2.5
75− issue: none
76− authors: phadej
77− date: 2018-03-23
78−
79− - version: "0.0.6.0"
80− changes:
81−
82− - description: Support for servant-0.12
83− issue: none
84− authors: phadej
85− date: 2018-02-09
86−
87− - version: "0.0.5.0"
88− changes:
89−
90− - description: Export forgotten predicates
91− issue: none
92− pr: 40
93− authors: Phenitei
94− date: 2017-12-14
95−
96− - version: "0.0.4"
97− changes:
98−
99− - description: Support for Servant 0.12
100− issue: none
101− authors: phadej
102− date: 2017-11-07
103−
104− - description: Support for Servant 0.11
105− issue: none
106− pr: 32
107− authors: adinapoli-iohk
108− date: 2017-10-18
109− notes: Includes 0-weighted instance for EmptyAPI
110−
111− - version: "0.0.3.0"
112− changes:
113−
114− - description: Add jsonEquality
115− issue: 2
116− pr: 30
117− authors: erewok
118− date: 2017-10-15
119−
120− - description: Support hspec >= 2.4
121− issue: 27
122− pr: 29
123− authors: erewok, jkarni
124− date: 2017-10-15
125−
126− - version: "0.0.2.4"
127− changes:
128−
129− - description: Don't append slashes to paths
130− issue: 22
131− authors: declension
132− date: 2017-03-11
133−
134− - version: "0.0.2.3"
135− changes:
136−
137− - description: Fix QueryParam and QueryFlag requests
138− issue: 23
139− authors: declension
140− date: 2017-03-10
141−
142− - version: "0.0.2.2"
143− changes:
144−
145− - description: Make onlyJsonObjects succeed in non-JSON endpoints
146− issue: 20
147− authors: jkarni
148− date: 2016-10-18
149−
150−
151− - version: "0.0.2.1"
152− changes:
153−
154− - description: Add notLongerThan predicate
155− pr: 17
156− authors: jkarni
157− date: 2016-10-05
158−
159− - description: Add getsHaveLastModifiedHeader predicate
160− pr: none
161− authors: jkarni
162− date: 2016-10-03
163−
164− - description: Raise upper bounds
165− notes: >
166− For Quickcheck, aeson, http-client, servant, servant-client and
167− servant-server.
168− pr: none
169− authors: jkarni
170− date: 2016-10-03
171
2
3+releases:
172
4
173 - version: "0.0.2.0"
5 - version: "0.0.2.0"
174 changes:
6 changes:
cabal.haskell-cideleted−7
@@ -1,7 +0,0 @@
1−branches: master
2−
3−constraint-set base-compat-0.10
4− constraints: base-compat ==0.10.*
5−
6−constraint-set base-compat-0.11
7− constraints: base-compat ==0.11.*
cabal.projectdeleted−4
@@ -1,4 +0,0 @@
1−packages: .
2−tests: true
3−
4−allow-newer: servant-blaze:servant
example/Main.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, DataKinds #-}
2−module Main (main) where
3−
4−import Servant
5−import Servant.QuickCheck
6−import Test.Hspec
7−import Data.Text (Text)
8−import System.Environment (getArgs)
9−
10−main :: IO ()
11−main = do
12− args <- getArgs
13− case args of
14− [] -> putStrLn "Not running without arguments. Try --help or --fail-fast."
15− _ -> hspec spec
16−
17−-- Change to String to reproduce
18−-- https://github.com/haskell-servant/servant-quickcheck/issues/41
19−type API = Get '[PlainText] Text
20−
21−api :: Proxy API
22−api = Proxy
23−
24−server :: Server API
25−server = return "Sigurð Fáfnirslayer"
26−
27−spec :: Spec
28−spec = describe "example server" $
29− it "mangles UTF-8 in error messages" $
30− withServantServer api (return server) $ \burl ->
31− serverSatisfies api burl defaultArgs (getsHaveCacheControlHeader <%> mempty)
servant-quickcheck.cabal+91−123
@@ -1,22 +1,22 @@
1−name: servant-quickcheck
1+name: servant-quickcheck
2−version: 0.0.9.1
2+version: 0.0.2.0
3−synopsis: QuickCheck entire APIs
3+synopsis: QuickCheck entire APIs
4description:
4description:
5− This packages provides QuickCheck properties that are tested across an entire
5+ This packages provides QuickCheck properties that are tested across an entire
6− API.
6+ API.
7
7
8−license: BSD3
8+license: BSD3
9−license-file: LICENSE
9+license-file: LICENSE
10−author: Julian K. Arni
10+author: Julian K. Arni
11−maintainer: jkarni@gmail.com
11+maintainer: jkarni@gmail.com
12−category: Web
12+category: Web
13−build-type: Simple
13+build-type: Simple
14−cabal-version: >=1.10
14+cabal-version: >=1.10
15−extra-source-files: CHANGELOG.yaml
15+extra-source-files:
16−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3
16+ CHANGELOG.yaml
17
17
18source-repository head
18source-repository head
19− type: git
19+ type: git
20 location: https://github.com/haskell-servant/servant-quickcheck
20 location: https://github.com/haskell-servant/servant-quickcheck
21
21
22flag long-tests
22flag long-tests
@@ -24,115 +24,83 @@ flag long-tests
24 default: False
24 default: False
25
25
26library
26library
27− exposed-modules:
27+ exposed-modules: Servant.QuickCheck
28+ , Servant.QuickCheck.Internal
29+ , Servant.QuickCheck.Internal.Predicates
28− Servant.QuickCheck
30+ , Servant.QuickCheck.Internal.HasGenRequest
29− Servant.QuickCheck.Internal
31+ , Servant.QuickCheck.Internal.QuickCheck
30− Servant.QuickCheck.Internal.Equality
32+ , Servant.QuickCheck.Internal.Equality
31− Servant.QuickCheck.Internal.ErrorTypes
33+ , Servant.QuickCheck.Internal.ErrorTypes
32− Servant.QuickCheck.Internal.HasGenRequest
34+ build-depends: base >=4.8 && <4.10
33− Servant.QuickCheck.Internal.Predicates
35+ , base-compat == 0.9.*
36+ , aeson > 0.8 && < 0.12
37+ , bytestring == 0.10.*
38+ , case-insensitive == 1.2.*
39+ , data-default-class >= 0.0 && < 0.2
40+ , hspec == 2.2.*
41+ , http-client >= 0.4.30 && < 0.5
42+ , http-media == 0.6.*
43+ , http-types > 0.8 && < 0.10
44+ , mtl > 2.1 && < 2.3
45+ , pretty == 1.1.*
46+ , process >= 1.2 && < 1.5
34− Servant.QuickCheck.Internal.QuickCheck
47+ , QuickCheck > 2.7 && < 2.9
48+ , servant > 0.6 && < 0.9
49+ , servant-client > 0.6 && < 0.9
50+ , servant-server > 0.6 && < 0.9
51+ , split == 0.2.*
52+ , string-conversions > 0.3 && < 0.5
53+ , temporary == 1.2.*
54+ , text == 1.*
55+ , time == 1.5.*
56+ , warp >= 3.2.4 && < 3.3
35
57
36− build-depends:
37− aeson >=0.8 && <2
38− , base >=4.9 && <4.15
39− , base-compat-batteries >=0.10.1 && <0.12
40− , bytestring >=0.10 && <0.11
41− , case-insensitive >=1.2 && <1.3
42− , clock >=0.7 && <0.9
43− , data-default-class >=0.0 && <0.2
44− , hspec >=2.5.6 && <2.8
45− , http-client >=0.4.30 && <0.8
46− , http-media >=0.6 && <0.9
47− , http-types >=0.8 && <0.13
48− , mtl >=2.1 && <2.3
49− , pretty >=1.1 && <1.2
50− , process >=1.2 && <1.7
51− , QuickCheck >=2.7 && <2.15
52− , servant >=0.17 && <0.19
53− , servant-client >=0.17 && <0.19
54− , servant-server >=0.17 && <0.19
55− , split >=0.2 && <0.3
56− , string-conversions >=0.3 && <0.5
57− , temporary >=1.2 && <1.4
58− , text >=1 && <2
59− , time >=1.5 && <1.11
60− , warp >=3.2.4 && <3.4
61−
62− if !impl(ghc >=8.0)
63− build-depends: semigroups >=0.18.3 && <0.20
64−
65− hs-source-dirs: src
58+ hs-source-dirs: src
66− default-extensions:
59+ default-extensions: TypeOperators
67− NoImplicitPrelude
60+ , FlexibleInstances
68− ConstraintKinds
61+ , FlexibleContexts
69− DataKinds
62+ , DataKinds
70− DeriveDataTypeable
63+ , GADTs
64+ , MultiParamTypeClasses
71− DeriveFunctor
65+ , DeriveFunctor
72− DeriveGeneric
73− FlexibleContexts
74− FlexibleInstances
75− FunctionalDependencies
76− GADTs
77− KindSignatures
66+ , KindSignatures
78− MultiParamTypeClasses
79− OverloadedStrings
80− RankNTypes
67+ , RankNTypes
68+ , ConstraintKinds
69+ , DeriveGeneric
81− ScopedTypeVariables
70+ , ScopedTypeVariables
82− TypeOperators
71+ , OverloadedStrings
83−
72+ , FunctionalDependencies
73+ , NoImplicitPrelude
74+ , DeriveDataTypeable
84− default-language: Haskell2010
75+ default-language: Haskell2010
85
76
86test-suite spec
77test-suite spec
87− type: exitcode-stdio-1.0
78+ type: exitcode-stdio-1.0
88− ghc-options: -Wall -threaded
79+ ghc-options: -Wall -threaded
89− default-language: Haskell2010
80+ default-language: Haskell2010
90− hs-source-dirs: test
81+ hs-source-dirs: test
91− main-is: Spec.hs
82+ main-is: Spec.hs
92− other-modules: Servant.QuickCheck.InternalSpec
83+ other-modules: Servant.QuickCheck.InternalSpec
93− build-tool-depends: hspec-discover:hspec-discover -any
84+ build-depends: base == 4.*
94− build-depends:
95− aeson
96− , base
97− , base-compat-batteries
85+ , base-compat
98− , blaze-html
86+ , servant-quickcheck
99− , bytestring
100− , hspec
87+ , hspec
101− , hspec-core >=2.5.5 && <2.8
88+ , hspec-core
102− , http-client
89+ , http-client
103− , QuickCheck
90+ , warp
104− , quickcheck-io
105− , servant
106− , servant-blaze
107− , servant-client
108− , servant-quickcheck
109− , servant-server
91+ , servant-server
92+ , servant-client
93+ , servant
110− , transformers
94+ , transformers
111− , warp
95+ , QuickCheck
112−
96+ , quickcheck-io
113− default-extensions:
97+ default-extensions: TypeOperators
114− NoImplicitPrelude
115− DataKinds
116− FlexibleContexts
117− FlexibleInstances
98+ , FlexibleInstances
99+ , FlexibleContexts
118− GADTs
100+ , GADTs
101+ , DataKinds
102+ , NoImplicitPrelude
119− OverloadedStrings
103+ , OverloadedStrings
120− ScopedTypeVariables
104+ , ScopedTypeVariables
121− TypeOperators
122−
123 if flag(long-tests)
105 if flag(long-tests)
124− cpp-options: -DLONG_TESTS
106+ cpp-options: -DLONG_TESTS
125−
126−test-suite example
127− type: exitcode-stdio-1.0
128− main-is: Main.hs
129− hs-source-dirs: example
130− ghc-options: -Wall
131− build-depends:
132− base
133− , hspec
134− , servant-quickcheck
135− , servant-server
136− , text
137−
138− default-language: Haskell2010
src/Servant/QuickCheck.hs−7
@@ -27,18 +27,12 @@ module Servant.QuickCheck
27 -- in RFCs. The __Best Practices__ includes, in addition to RFC
27 -- in RFCs. The __Best Practices__ includes, in addition to RFC
28 -- recommendations, recommendations found elsewhere or generally accepted.
28 -- recommendations, recommendations found elsewhere or generally accepted.
29 , not500
29 , not500
30− , notLongerThan
31 , onlyJsonObjects
30 , onlyJsonObjects
32− , honoursAcceptHeader
33 , notAllowedContainsAllowHeader
31 , notAllowedContainsAllowHeader
34 , unauthorizedContainsWWWAuthenticate
32 , unauthorizedContainsWWWAuthenticate
35− , getsHaveLastModifiedHeader
36 , getsHaveCacheControlHeader
33 , getsHaveCacheControlHeader
37 , headsHaveCacheControlHeader
34 , headsHaveCacheControlHeader
38 , createContainsValidLocation
35 , createContainsValidLocation
39− -- * Html Predicates
40− , htmlIncludesDoctype
41−
42 -- *** Predicate utilities and types
36 -- *** Predicate utilities and types
43 , (<%>)
37 , (<%>)
44 , Predicates
38 , Predicates
@@ -54,7 +48,6 @@ module Servant.QuickCheck
54 -- represents other means of checking equality
48 -- represents other means of checking equality
55 -- *** Useful @ResponseEquality@s
49 -- *** Useful @ResponseEquality@s
56 , bodyEquality
50 , bodyEquality
57− , jsonEquality
58 , allEquality
51 , allEquality
59 -- ** Response equality type
52 -- ** Response equality type
60 , ResponseEquality(..)
53 , ResponseEquality(..)
src/Servant/QuickCheck/Internal/Equality.hs+2−35
@@ -1,23 +1,16 @@
1module Servant.QuickCheck.Internal.Equality where
1module Servant.QuickCheck.Internal.Equality where
2
2
3−import Data.Aeson (Value, decode, decodeStrict)
4−import Data.ByteString (ByteString)
5−import qualified Data.ByteString.Lazy as LB
6import Data.Function (on)
3import Data.Function (on)
7import Network.HTTP.Client (Response, responseBody)
4import Network.HTTP.Client (Response, responseBody)
8−import Data.Semigroup (Semigroup (..))
9import Prelude.Compat
5import Prelude.Compat
10
6
11newtype ResponseEquality b
7newtype ResponseEquality b
12 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
8 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
13
9
14−instance Semigroup (ResponseEquality b) where
15− ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y ->
16− a x y && b x y
17−
18instance Monoid (ResponseEquality b) where
10instance Monoid (ResponseEquality b) where
19 mempty = ResponseEquality $ \_ _ -> True
11 mempty = ResponseEquality $ \_ _ -> True
20− mappend = (<>)
12+ ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->
13+ a x y && b x y
21
14
22-- | Use `Eq` instance for `Response`
15-- | Use `Eq` instance for `Response`
23--
16--
@@ -30,29 +23,3 @@ allEquality = ResponseEquality (==)
30-- /Since 0.0.0.0/
23-- /Since 0.0.0.0/
31bodyEquality :: Eq b => ResponseEquality b
24bodyEquality :: Eq b => ResponseEquality b
32bodyEquality = ResponseEquality ((==) `on` responseBody)
25bodyEquality = ResponseEquality ((==) `on` responseBody)
33−
34−-- | Equality as 'Value'. This means that if two bodies are equal as JSON
35−-- (e.g., insignificant whitespace difference) they are considered equal.
36−--
37−-- /Since 0.0.3.0/
38−jsonEquality :: (JsonEq b) => ResponseEquality b
39−jsonEquality = ResponseEquality (jsonEq `on` responseBody)
40−
41−class JsonEq a where
42− decode' :: a -> Maybe Value
43− jsonEq :: a -> a -> Bool
44− jsonEq first second = compareDecodedResponses (decode' first) (decode' second)
45−
46−instance JsonEq LB.ByteString where
47− decode' = decode
48−
49−instance JsonEq ByteString where
50− decode' = decodeStrict
51−
52−compareDecodedResponses :: Maybe Value -> Maybe Value -> Bool
53−compareDecodedResponses resp1 resp2 =
54− case resp1 of
55− Nothing -> False -- if decoding fails we assume failure
56− (Just r1) -> case resp2 of
57− Nothing -> False -- another decode failure
58− (Just r2) -> r1 == r2
src/Servant/QuickCheck/Internal/ErrorTypes.hs+1−3
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2module Servant.QuickCheck.Internal.ErrorTypes where
1module Servant.QuickCheck.Internal.ErrorTypes where
3
2
4import Control.Exception (Exception (..))
3import Control.Exception (Exception (..))
@@ -9,10 +8,9 @@ import Data.Typeable (Typeable)
9import GHC.Generics (Generic)
8import GHC.Generics (Generic)
10import qualified Network.HTTP.Client as C
9import qualified Network.HTTP.Client as C
11import Network.HTTP.Types (Header, statusCode)
10import Network.HTTP.Types (Header, statusCode)
11+import Prelude.Compat
12import Text.PrettyPrint
12import Text.PrettyPrint
13
13
14−import Prelude.Compat hiding ((<>))
15−
16data PredicateFailure
14data PredicateFailure
17 = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
15 = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
18 deriving (Typeable, Generic)
16 deriving (Typeable, Generic)
src/Servant/QuickCheck/Internal/HasGenRequest.hs+47−92
@@ -2,147 +2,112 @@
2{-# LANGUAGE PolyKinds #-}
2{-# LANGUAGE PolyKinds #-}
3module Servant.QuickCheck.Internal.HasGenRequest where
3module Servant.QuickCheck.Internal.HasGenRequest where
4
4
5+import Data.Default.Class (def)
6+import Data.Monoid ((<>))
5import Data.String (fromString)
7import Data.String (fromString)
6import Data.String.Conversions (cs)
8import Data.String.Conversions (cs)
9+import qualified Data.ByteString as BS
7import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
10import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
8import Network.HTTP.Client (Request, RequestBody (..), host, method, path,
11import Network.HTTP.Client (Request, RequestBody (..), host, method, path,
9 port, queryString, requestBody, requestHeaders,
12 port, queryString, requestBody, requestHeaders,
10− secure, defaultRequest)
13+ secure)
11import Network.HTTP.Media (renderHeader)
14import Network.HTTP.Media (renderHeader)
12import Prelude.Compat
15import Prelude.Compat
13import Servant
16import Servant
14import Servant.API.ContentTypes (AllMimeRender (..))
17import Servant.API.ContentTypes (AllMimeRender (..))
15import Servant.Client (BaseUrl (..), Scheme (..))
18import Servant.Client (BaseUrl (..), Scheme (..))
16−import Test.QuickCheck (Arbitrary (..), Gen, elements, frequency)
19+import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)
17−
18−import qualified Data.ByteString as BS
19−import qualified Data.ByteString.Internal as BS (c2w)
20−
21−
22−-- -----------------------------------------------------------------------------
23−-- runGenRequest
24−
25−-- | This function returns a QuickCheck `Gen a` when passed a servant API value,
26−-- typically a `Proxy API`. The generator returned is a function
27−-- that accepts a `BaseUrl` and returns a `Request`, which can then be used
28−-- to issue network requests. This `Gen` type makes it easier to compare distinct
29−-- APIs across different `BaseUrl`s.
30−runGenRequest :: HasGenRequest a => Proxy a -> Gen (BaseUrl -> Request)
31−runGenRequest = snd . genRequest
32−
33
20
34−-- -----------------------------------------------------------------------------
35−-- HasGenRequest
36
21
37−-- | This is the core Servant-Quickcheck generator, which, when given a `Proxy API`
38−-- will return a pair of `Int` and `Gen a`, where `a` is a function from
39−-- `BaseUrl` to a `Network.Http.Client.Request`. The `Int` is a weight for the
40−-- QuickCheck `frequency` function which ensures a random distribution across
41−-- all endpoints in an API.
42class HasGenRequest a where
22class HasGenRequest a where
43− genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))
23+ genRequest :: Proxy a -> Gen (BaseUrl -> Request)
44−
45
24
46instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
25instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
47 genRequest _
26 genRequest _
48− = (lf + rf, frequency [l, r])
49− where
50− l@(lf, _) = genRequest (Proxy :: Proxy a)
27+ = oneof [ genRequest (Proxy :: Proxy a)
51− r@(rf, _) = genRequest (Proxy :: Proxy b)
28+ , genRequest (Proxy :: Proxy b)
52−
29+ ]
53
30
54instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
31instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
55− genRequest _ = (oldf, do
32+ genRequest _ = do
56 old' <- old
33 old' <- old
57− return $ \burl -> let r = old' burl
34+ return $ \burl -> let r = old' burl in r { path = new <> path r }
58− oldPath = path r
59− oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
60− paths = filter (not . BS.null) [new, oldPath']
61− in r { path = "/" <> BS.intercalate "/" paths })
62 where
35 where
63− (oldf, old) = genRequest (Proxy :: Proxy b)
36+ old = genRequest (Proxy :: Proxy b)
64 new = cs $ symbolVal (Proxy :: Proxy path)
37 new = cs $ symbolVal (Proxy :: Proxy path)
65
38
66−instance HasGenRequest EmptyAPI where
67− genRequest _ = (0, error "EmptyAPIs cannot be queried.")
68−
69−instance HasGenRequest api => HasGenRequest (Summary d :> api) where
70− genRequest _ = genRequest (Proxy :: Proxy api)
71−
72−instance HasGenRequest api => HasGenRequest (Description d :> api) where
73− genRequest _ = genRequest (Proxy :: Proxy api)
74−
75instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
39instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
76− => HasGenRequest (Capture' mods x c :> b) where
40+ => HasGenRequest (Capture x c :> b) where
77− genRequest _ = (oldf, do
41+ genRequest _ = do
78 old' <- old
42 old' <- old
79 new' <- toUrlPiece <$> new
43 new' <- toUrlPiece <$> new
80− return $ \burl -> let r = old' burl in r { path = cs new' <> path r })
44+ return $ \burl -> let r = old' burl in r { path = cs new' <> path r }
81 where
45 where
82− (oldf, old) = genRequest (Proxy :: Proxy b)
46+ old = genRequest (Proxy :: Proxy b)
83 new = arbitrary :: Gen c
47 new = arbitrary :: Gen c
84
48
49+#if MIN_VERSION_servant(0,8,0)
85instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
50instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
86 => HasGenRequest (CaptureAll x c :> b) where
51 => HasGenRequest (CaptureAll x c :> b) where
87− genRequest _ = (oldf, do
52+ genRequest _ = do
88 old' <- old
53 old' <- old
89 new' <- fmap (cs . toUrlPiece) <$> new
54 new' <- fmap (cs . toUrlPiece) <$> new
90 let new'' = BS.intercalate "/" new'
55 let new'' = BS.intercalate "/" new'
91− return $ \burl -> let r = old' burl in r { path = new'' <> path r })
56+ return $ \burl -> let r = old' burl in r { path = new'' <> path r }
92 where
57 where
93− (oldf, old) = genRequest (Proxy :: Proxy b)
58+ old = genRequest (Proxy :: Proxy b)
94 new = arbitrary :: Gen [c]
59 new = arbitrary :: Gen [c]
60+#endif
95
61
96instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
62instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
97− => HasGenRequest (Header' mods h c :> b) where
63+ => HasGenRequest (Header h c :> b) where
98− genRequest _ = (oldf, do
64+ genRequest _ = do
99 old' <- old
65 old' <- old
100− new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
66+ new' <- toUrlPiece <$> new
101 return $ \burl -> let r = old' burl in r {
67 return $ \burl -> let r = old' burl in r {
102− requestHeaders = (hdr, cs new') : requestHeaders r })
68+ requestHeaders = (hdr, cs new') : requestHeaders r }
103 where
69 where
104− (oldf, old) = genRequest (Proxy :: Proxy b)
70+ old = genRequest (Proxy :: Proxy b)
105 hdr = fromString $ symbolVal (Proxy :: Proxy h)
71 hdr = fromString $ symbolVal (Proxy :: Proxy h)
106 new = arbitrary :: Gen c
72 new = arbitrary :: Gen c
107
73
108instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
74instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
109− => HasGenRequest (ReqBody' mods x c :> b) where
75+ => HasGenRequest (ReqBody x c :> b) where
110− genRequest _ = (oldf, do
76+ genRequest _ = do
111− old' <- old -- TODO: generate lenient
77+ old' <- old
112 new' <- new
78 new' <- new
113 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
79 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
114 return $ \burl -> let r = old' burl in r {
80 return $ \burl -> let r = old' burl in r {
115 requestBody = RequestBodyLBS bd
81 requestBody = RequestBodyLBS bd
116 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
82 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
117− })
83+ }
118 where
84 where
119− (oldf, old) = genRequest (Proxy :: Proxy b)
85+ old = genRequest (Proxy :: Proxy b)
120 new = arbitrary :: Gen c
86 new = arbitrary :: Gen c
121
87
122instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
88instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
123− => HasGenRequest (QueryParam' mods x c :> b) where
89+ => HasGenRequest (QueryParam x c :> b) where
124− genRequest _ = (oldf, do
90+ genRequest _ = do
125− new' <- new -- TODO: generate lenient or/and optional
91+ new' <- new
126 old' <- old
92 old' <- old
127− return $ \burl -> let r = old' burl
93+ return $ \burl -> let r = old' burl in r {
94+ queryString = queryString r
128− newExpr = param <> "=" <> cs (toQueryParam new')
95+ <> param <> "=" <> cs (toQueryParam new') }
129− qs = queryString r in r {
130− queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
131 where
96 where
132− (oldf, old) = genRequest (Proxy :: Proxy b)
97+ old = genRequest (Proxy :: Proxy b)
133 param = cs $ symbolVal (Proxy :: Proxy x)
98 param = cs $ symbolVal (Proxy :: Proxy x)
134 new = arbitrary :: Gen c
99 new = arbitrary :: Gen c
135
100
136instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
101instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
137 => HasGenRequest (QueryParams x c :> b) where
102 => HasGenRequest (QueryParams x c :> b) where
138− genRequest _ = (oldf, do
103+ genRequest _ = do
139 new' <- new
104 new' <- new
140 old' <- old
105 old' <- old
141 return $ \burl -> let r = old' burl in r {
106 return $ \burl -> let r = old' burl in r {
142 queryString = queryString r
107 queryString = queryString r
143− <> if length new' > 0 then fold (toParam <$> new') else ""})
108+ <> if length new' > 0 then fold (toParam <$> new') else ""}
144 where
109 where
145− (oldf, old) = genRequest (Proxy :: Proxy b)
110+ old = genRequest (Proxy :: Proxy b)
146 param = cs $ symbolVal (Proxy :: Proxy x)
111 param = cs $ symbolVal (Proxy :: Proxy x)
147 new = arbitrary :: Gen [c]
112 new = arbitrary :: Gen [c]
148 toParam c = param <> "[]=" <> cs (toQueryParam c)
113 toParam c = param <> "[]=" <> cs (toQueryParam c)
@@ -150,32 +115,22 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
150
115
151instance (KnownSymbol x, HasGenRequest b)
116instance (KnownSymbol x, HasGenRequest b)
152 => HasGenRequest (QueryFlag x :> b) where
117 => HasGenRequest (QueryFlag x :> b) where
153− genRequest _ = (oldf, do
118+ genRequest _ = do
154 old' <- old
119 old' <- old
155− return $ \burl -> let r = old' burl
120+ return $ \burl -> let r = old' burl in r {
156− qs = queryString r in r {
157− queryString = if BS.null qs then param else param <> "&" <> qs })
121+ queryString = queryString r <> param <> "=" }
158 where
122 where
159− (oldf, old) = genRequest (Proxy :: Proxy b)
123+ old = genRequest (Proxy :: Proxy b)
160 param = cs $ symbolVal (Proxy :: Proxy x)
124 param = cs $ symbolVal (Proxy :: Proxy x)
161
125
162instance (ReflectMethod method)
126instance (ReflectMethod method)
163 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
127 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
164− genRequest _ = (1, return $ \burl -> defaultRequest
128+ genRequest _ = return $ \burl -> def
165− { host = cs $ baseUrlHost burl
166− , port = baseUrlPort burl
167− , secure = baseUrlScheme burl == Https
168− , method = reflectMethod (Proxy :: Proxy method)
169− })
170−
171−instance (ReflectMethod method)
172− => HasGenRequest (NoContentVerb (method :: k)) where
173− genRequest _ = (1, return $ \burl -> defaultRequest
174 { host = cs $ baseUrlHost burl
129 { host = cs $ baseUrlHost burl
175 , port = baseUrlPort burl
130 , port = baseUrlPort burl
176 , secure = baseUrlScheme burl == Https
131 , secure = baseUrlScheme burl == Https
177 , method = reflectMethod (Proxy :: Proxy method)
132 , method = reflectMethod (Proxy :: Proxy method)
178− })
133+ }
179
134
180instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
135instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
181 genRequest _ = genRequest (Proxy :: Proxy a)
136 genRequest _ = genRequest (Proxy :: Proxy a)
src/Servant/QuickCheck/Internal/Predicates.hs+35−96
@@ -1,33 +1,28 @@
1module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
2
2
3import Control.Exception (catch, throw)
3import Control.Exception (catch, throw)
4−import Control.Monad (liftM2, unless, when)
4+import Control.Monad (when, unless, liftM2)
5import Data.Aeson (Object, decode)
5import Data.Aeson (Object, decode)
6−import Data.Bifunctor (first)
7import qualified Data.ByteString as SBS
6import qualified Data.ByteString as SBS
8import qualified Data.ByteString.Char8 as SBSC
7import qualified Data.ByteString.Char8 as SBSC
9import qualified Data.ByteString.Lazy as LBS
8import qualified Data.ByteString.Lazy as LBS
10−import Data.CaseInsensitive (foldCase, foldedCase, mk)
9+import Data.CaseInsensitive (mk)
11import Data.Either (isRight)
10import Data.Either (isRight)
12import Data.List.Split (wordsBy)
11import Data.List.Split (wordsBy)
13import Data.Maybe (fromMaybe, isJust)
12import Data.Maybe (fromMaybe, isJust)
14−import Data.Semigroup (Semigroup (..))
13+import Data.Monoid ((<>))
15−import qualified Data.Text as T
16−import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
14+import Data.Time (parseTimeM, defaultTimeLocale,
17− rfc822DateFormat)
15+ rfc822DateFormat, UTCTime)
18import GHC.Generics (Generic)
16import GHC.Generics (Generic)
19import Network.HTTP.Client (Manager, Request, Response, httpLbs,
17import Network.HTTP.Client (Manager, Request, Response, httpLbs,
20− method, parseRequest, requestHeaders,
18+ method, requestHeaders, responseBody,
21− responseBody, responseHeaders,
22− responseStatus)
19+ responseHeaders, parseRequest, responseStatus)
23import Network.HTTP.Media (matchAccept)
20import Network.HTTP.Media (matchAccept)
24import Network.HTTP.Types (methodGet, methodHead, parseMethod,
21import Network.HTTP.Types (methodGet, methodHead, parseMethod,
25 renderStdMethod, status100, status200,
22 renderStdMethod, status100, status200,
26 status201, status300, status401,
23 status201, status300, status401,
27 status405, status500)
24 status405, status500)
28import Prelude.Compat
25import Prelude.Compat
29−import System.Clock (Clock (Monotonic), diffTimeSpec,
30− getTime, toNanoSecs)
31
26
32import Servant.QuickCheck.Internal.ErrorTypes
27import Servant.QuickCheck.Internal.ErrorTypes
33
28
@@ -43,23 +38,7 @@ import Servant.QuickCheck.Internal.ErrorTypes
43-- /Since 0.0.0.0/
38-- /Since 0.0.0.0/
44not500 :: ResponsePredicate
39not500 :: ResponsePredicate
45not500 = ResponsePredicate $ \resp ->
40not500 = ResponsePredicate $ \resp ->
46− when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
41+ when (responseStatus resp == status500) $ fail "not500"
47−
48−-- | [__Optional__]
49−--
50−-- This function checks that the response from the server does not take longer
51−-- than the specified number of nanoseconds.
52−--
53−-- /Since 0.0.2.1/
54−notLongerThan :: Integer -> RequestPredicate
55−notLongerThan maxAllowed
56− = RequestPredicate $ \req mgr -> do
57− start <- getTime Monotonic
58− resp <- httpLbs req mgr
59− end <- getTime Monotonic
60− when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $
61− throw $ PredicateFailure "notLongerThan" (Just req) resp
62− return []
63
42
64-- | [__Best Practice__]
43-- | [__Best Practice__]
65--
44--
@@ -84,13 +63,9 @@ notLongerThan maxAllowed
84-- /Since 0.0.0.0/
63-- /Since 0.0.0.0/
85onlyJsonObjects :: ResponsePredicate
64onlyJsonObjects :: ResponsePredicate
86onlyJsonObjects
65onlyJsonObjects
87− = ResponsePredicate (\resp -> do
88− case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
89− Nothing -> return ()
90− Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do
91− case (decode (responseBody resp) :: Maybe Object) of
66+ = ResponsePredicate (\resp -> case decode (responseBody resp) of
92− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
67+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
93− Just _ -> return ())
68+ Just (_ :: Object) -> return ())
94
69
95-- | __Optional__
70-- | __Optional__
96--
71--
@@ -118,12 +93,12 @@ createContainsValidLocation
118 resp <- httpLbs req mgr
93 resp <- httpLbs req mgr
119 if responseStatus resp == status201
94 if responseStatus resp == status201
120 then case lookup "Location" $ responseHeaders resp of
95 then case lookup "Location" $ responseHeaders resp of
121− Nothing -> throw $ PredicateFailure n (Just req) resp
96+ Nothing -> fail n
122 Just l -> case parseRequest $ SBSC.unpack l of
97 Just l -> case parseRequest $ SBSC.unpack l of
123− Nothing -> throw $ PredicateFailure n (Just req) resp
98+ Nothing -> fail n
124 Just x -> do
99 Just x -> do
125 resp2 <- httpLbs x mgr
100 resp2 <- httpLbs x mgr
126− status2XX (Just req) resp2 n
101+ status2XX resp2 n
127 return [resp, resp2]
102 return [resp, resp2]
128 else return [resp]
103 else return [resp]
129
104
@@ -151,7 +126,7 @@ createContainsValidLocation
151-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
126-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
152-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
127-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
153--
128--
154−-- /Since 0.0.2.1/
129+-- #SINCECURRENT#
155getsHaveLastModifiedHeader :: RequestPredicate
130getsHaveLastModifiedHeader :: RequestPredicate
156getsHaveLastModifiedHeader
131getsHaveLastModifiedHeader
157 = RequestPredicate $ \req mgr ->
132 = RequestPredicate $ \req mgr ->
@@ -175,27 +150,23 @@ getsHaveLastModifiedHeader
175-- This function checks that every @405 Method Not Allowed@ response contains
150-- This function checks that every @405 Method Not Allowed@ response contains
176-- an @Allow@ header with a list of standard HTTP methods.
151-- an @Allow@ header with a list of standard HTTP methods.
177--
152--
178−-- Note that 'servant' itself does not currently set the @Allow@ headers.
179−--
180-- __References__:
153-- __References__:
181--
154--
182-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
155-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
183-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
156-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
184−-- * Servant Allow header issue: <https://github.com/haskell-servant/servant/issues/489 Issue #489>
185--
157--
186-- /Since 0.0.0.0/
158-- /Since 0.0.0.0/
187notAllowedContainsAllowHeader :: RequestPredicate
159notAllowedContainsAllowHeader :: RequestPredicate
188notAllowedContainsAllowHeader
160notAllowedContainsAllowHeader
189 = RequestPredicate $ \req mgr -> do
161 = RequestPredicate $ \req mgr -> do
190− let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
162+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
163+ | m <- [minBound .. maxBound ]
191− , renderStdMethod m /= method req ]
164+ , renderStdMethod m /= method req ]
192− resp <- mapM (flip httpLbs mgr) reqs
193−
194− case filter pred' (zip reqs resp) of
165+ case filter pred' resp of
195− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
166+ (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
196 [] -> return resp
167 [] -> return resp
197 where
168 where
198− pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
169+ pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
199 where
170 where
200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
171 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
172 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -225,7 +196,7 @@ honoursAcceptHeader
225 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
196 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
226 if status100 < scode && scode < status300
197 if status100 < scode && scode < status300
227 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
198 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
228− then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
199+ then fail "honoursAcceptHeader"
229 else return [resp]
200 else return [resp]
230 else return [resp]
201 else return [resp]
231
202
@@ -336,29 +307,7 @@ unauthorizedContainsWWWAuthenticate
336 = ResponsePredicate $ \resp ->
307 = ResponsePredicate $ \resp ->
337 if responseStatus resp == status401
308 if responseStatus resp == status401
338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
309 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339− throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
310+ fail "unauthorizedContainsWWWAuthenticate"
340− else return ()
341−
342−
343−-- | [__RFC Compliance__]
344−--
345−-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
346−--
347−-- This function checks that HTML documents (those with `Content-Type: text/html...`)
348−-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
349−--
350−-- __References__:
351−--
352−-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
353−-- /Since 0.3.0.0/
354−htmlIncludesDoctype :: ResponsePredicate
355−htmlIncludesDoctype
356− = ResponsePredicate $ \resp ->
357− if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
358− then do
359− let htmlContent = foldCase . LBS.take 20 $ responseBody resp
360− unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
361− throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
362 else return ()
311 else return ()
363
312
364-- * Predicate logic
313-- * Predicate logic
@@ -372,47 +321,37 @@ htmlIncludesDoctype
372-- | A predicate that depends only on the response.
321-- | A predicate that depends only on the response.
373--
322--
374-- /Since 0.0.0.0/
323-- /Since 0.0.0.0/
375−newtype ResponsePredicate = ResponsePredicate
324+data ResponsePredicate = ResponsePredicate
376 { getResponsePredicate :: Response LBS.ByteString -> IO ()
325 { getResponsePredicate :: Response LBS.ByteString -> IO ()
377 } deriving (Generic)
326 } deriving (Generic)
378
327
379−instance Semigroup ResponsePredicate where
380− ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
381−
382instance Monoid ResponsePredicate where
328instance Monoid ResponsePredicate where
383 mempty = ResponsePredicate $ const $ return ()
329 mempty = ResponsePredicate $ const $ return ()
384− mappend = (<>)
330+ ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
385
331
386-- | A predicate that depends on both the request and the response.
332-- | A predicate that depends on both the request and the response.
387--
333--
388-- /Since 0.0.0.0/
334-- /Since 0.0.0.0/
389−newtype RequestPredicate = RequestPredicate
335+data RequestPredicate = RequestPredicate
390− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
336+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
391 } deriving (Generic)
337 } deriving (Generic)
392
338
393-- TODO: This isn't actually a monoid
339-- TODO: This isn't actually a monoid
394instance Monoid RequestPredicate where
340instance Monoid RequestPredicate where
395 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
341 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
396− mappend = (<>)
397−
398−-- TODO: This isn't actually a monoid
399−instance Semigroup RequestPredicate where
400− RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
342+ RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
401 liftM2 (<>) (a r mgr) (b r mgr)
343 liftM2 (<>) (a r mgr) (b r mgr)
402
344
403-- | A set of predicates. Construct one with 'mempty' and '<%>'.
345-- | A set of predicates. Construct one with 'mempty' and '<%>'.
404data Predicates = Predicates
346data Predicates = Predicates
405− { requestPredicates :: RequestPredicate
347+ { requestPredicates :: RequestPredicate
406 , responsePredicates :: ResponsePredicate
348 , responsePredicates :: ResponsePredicate
407 } deriving (Generic)
349 } deriving (Generic)
408
350
409−instance Semigroup Predicates where
410− a <> b = Predicates (requestPredicates a <> requestPredicates b)
411− (responsePredicates a <> responsePredicates b)
412−
413instance Monoid Predicates where
351instance Monoid Predicates where
414 mempty = Predicates mempty mempty
352 mempty = Predicates mempty mempty
415− mappend = (<>)
353+ a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
354+ (responsePredicates a <> responsePredicates b)
416
355
417class JoinPreds a where
356class JoinPreds a where
418 joinPreds :: a -> Predicates -> Predicates
357 joinPreds :: a -> Predicates -> Predicates
@@ -454,8 +393,8 @@ isRFC822Date s
454 Nothing -> False
393 Nothing -> False
455 Just (_ :: UTCTime) -> True
394 Just (_ :: UTCTime) -> True
456
395
457−status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
396+status2XX :: Monad m => Response b -> String -> m ()
458−status2XX mreq resp t
397+status2XX r t
459− | status200 <= responseStatus resp && responseStatus resp < status300
398+ | status200 <= responseStatus r && responseStatus r < status300
460 = return ()
399 = return ()
461− | otherwise = throw $ PredicateFailure t mreq resp
400+ | otherwise = fail t
src/Servant/QuickCheck/Internal/QuickCheck.hs+27−69
@@ -1,8 +1,7 @@
1{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE CPP #-}
3module Servant.QuickCheck.Internal.QuickCheck where
2module Servant.QuickCheck.Internal.QuickCheck where
4
3
5−import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
4+import Control.Concurrent (modifyMVar_, newMVar, readMVar)
6import Control.Monad (unless)
5import Control.Monad (unless)
7import qualified Data.ByteString.Lazy as LBS
6import qualified Data.ByteString.Lazy as LBS
8import Data.Proxy (Proxy)
7import Data.Proxy (Proxy)
@@ -11,13 +10,11 @@ import Network.Wai.Handler.Warp (withApplication)
11import Prelude.Compat
10import Prelude.Compat
12import Servant (Context (EmptyContext), HasServer,
11import Servant (Context (EmptyContext), HasServer,
13 Server, serveWithContext)
12 Server, serveWithContext)
14−#if MIN_VERSION_servant_server(0,18,0)
15−import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, type (.++))
16−#endif
17import Servant.Client (BaseUrl (..), Scheme (..))
13import Servant.Client (BaseUrl (..), Scheme (..))
18import System.IO.Unsafe (unsafePerformIO)
14import System.IO.Unsafe (unsafePerformIO)
19import Test.Hspec (Expectation, expectationFailure)
15import Test.Hspec (Expectation, expectationFailure)
20−import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)
16+import Test.QuickCheck (Args (..), Result (..),
17+ quickCheckWithResult)
21import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
18import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
22 run)
19 run)
23import Test.QuickCheck.Property (counterexample)
20import Test.QuickCheck.Property (counterexample)
@@ -40,11 +37,7 @@ withServantServer api = withServantServerAndContext api EmptyContext
40-- application.
37-- application.
41--
38--
42-- /Since 0.0.0.0/
39-- /Since 0.0.0.0/
43−#if MIN_VERSION_servant_server(0,18,0)
44−withServantServerAndContext :: (HasServer a ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters)
45−#else
46withServantServerAndContext :: HasServer a ctx
40withServantServerAndContext :: HasServer a ctx
47−#endif
48 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
41 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
49withServantServerAndContext api ctx server t
42withServantServerAndContext api ctx server t
50 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
43 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
@@ -77,32 +70,25 @@ withServantServerAndContext api ctx server t
77serversEqual :: HasGenRequest a =>
70serversEqual :: HasGenRequest a =>
78 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
71 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
79serversEqual api burl1 burl2 args req = do
72serversEqual api burl1 burl2 args req = do
80− let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
73+ let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
81 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
74 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
82 -- return results when a test fails, since an exception is throw.
75 -- return results when a test fails, since an exception is throw.
83− deetsMVar <- newEmptyMVar
76+ deetsMVar <- newMVar $ error "should not be called"
84 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
77 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
85 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
78 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
86 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
79 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
87 unless (getResponseEquality req resp1 resp2) $ do
80 unless (getResponseEquality req resp1 resp2) $ do
88 monitor (counterexample "hi" )
81 monitor (counterexample "hi" )
82+ run $ modifyMVar_ deetsMVar $ const $ return $
89− _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
83+ ServerEqualityFailure req1 resp1 resp2
90 assert False
84 assert False
91 case r of
85 case r of
92 Success {} -> return ()
86 Success {} -> return ()
93− Failure{..} -> do
87+ Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
94− mx <- tryReadMVar deetsMVar
95− case mx of
96− Just x ->
97− expectationFailure $ "Failed:\n" ++ show x
88+ "Failed:\n" ++ show x
98− Nothing ->
99− expectationFailure $ "We failed to record a reason for failure: " <> show r
100 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
89 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
101− NoExpectedFailure {} -> expectationFailure "No expected failure"
90+ NoExpectedFailure {} -> expectationFailure $ "No expected failure"
102−#if MIN_VERSION_QuickCheck(2,12,0)
103−#else
104− InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
91+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
105−#endif
106
92
107-- | Check that a server satisfies the set of properties specified.
93-- | Check that a server satisfies the set of properties specified.
108--
94--
@@ -125,68 +111,40 @@ serversEqual api burl1 burl2 args req = do
125-- /Since 0.0.0.0/
111-- /Since 0.0.0.0/
126serverSatisfies :: (HasGenRequest a) =>
112serverSatisfies :: (HasGenRequest a) =>
127 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
113 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
128−serverSatisfies api = serverSatisfiesMgr api defManager
114+serverSatisfies api burl args preds = do
129−
130−-- | Check that a server satisfies the set of properties specified, and
131−-- accept a 'Manager' for running the HTTP requests through.
132−--
133−-- See 'serverSatisfies' for more details.
134−--
135−-- @since 0.0.7.2
136−serverSatisfiesMgr :: (HasGenRequest a) =>
137− Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
138−serverSatisfiesMgr api manager burl args preds = do
139− let reqs = ($ burl) <$> runGenRequest api
115+ let reqs = ($ burl) <$> genRequest api
140− deetsMVar <- newEmptyMVar
116+ deetsMVar <- newMVar $ error "should not be called"
141 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
117 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
142− v <- run $ finishPredicates preds (noCheckStatus req) manager
118+ v <- run $ finishPredicates preds (noCheckStatus req) defManager
143− _ <- run $ tryPutMVar deetsMVar v
119+ run $ modifyMVar_ deetsMVar $ const $ return v
144− case v of
120+ case v of
145− Just _ -> assert False
121+ Just _ -> assert False
146− _ -> return ()
122+ _ -> return ()
147 case r of
123 case r of
148 Success {} -> return ()
124 Success {} -> return ()
149− Failure {..} -> do
125+ Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
150− mx <- tryReadMVar deetsMVar
151− case mx of
152− Just x ->
153− expectationFailure $ "Failed:\n" ++ show x
126+ "Failed:\n" ++ show x
154− Nothing ->
155− expectationFailure $ "We failed to record a reason for failure: " <> show r
156 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
127 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
157 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
128 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
158−#if MIN_VERSION_QuickCheck(2,12,0)
159−#else
160− InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
129+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
161−#endif
130+
162
131
163serverDoesntSatisfy :: (HasGenRequest a) =>
132serverDoesntSatisfy :: (HasGenRequest a) =>
164 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
133 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
165−serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
134+serverDoesntSatisfy api burl args preds = do
166−
167−serverDoesntSatisfyMgr :: (HasGenRequest a) =>
168− Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
169−serverDoesntSatisfyMgr api manager burl args preds = do
170− let reqs = ($ burl) <$> runGenRequest api
135+ let reqs = ($ burl) <$> genRequest api
171 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
136 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
172− v <- run $ finishPredicates preds (noCheckStatus req) manager
137+ v <- run $ finishPredicates preds (noCheckStatus req) defManager
173 assert $ not $ null v
138 assert $ not $ null v
174 case r of
139 case r of
175 Success {} -> return ()
140 Success {} -> return ()
176 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
141 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
177 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
142 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
178 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
143 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
179−#if MIN_VERSION_QuickCheck(2,12,0)
180−#else
181− InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
144+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
182−#endif
183
145
184noCheckStatus :: C.Request -> C.Request
146noCheckStatus :: C.Request -> C.Request
185−#if MIN_VERSION_http_client(0,5,0)
186−noCheckStatus = id
187−#else
188noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
147noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
189−#endif
190
148
191defManager :: C.Manager
149defManager :: C.Manager
192defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
150defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
stack-ghc-8.0.1.yamlnew file+10
@@ -0,0 +1,10 @@
1+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
2+resolver: nightly-2016-09-07
3+packages:
4+- '.'
5+extra-deps:
6+- 'servant-0.8.1'
7+- 'servant-server-0.8.1'
8+- 'servant-client-0.8.1'
9+flags: {}
10+extra-package-dbs: []
stack.yaml+3−6
@@ -1,10 +1,7 @@
1+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
1−resolver: nightly-2018-09-03
2+resolver: lts-6.17
2packages:
3packages:
3- '.'
4- '.'
4−extra-deps:
5+extra-deps: []
5−- hspec-discover-2.5.6
6−- hspec-core-2.5.6
7−- hspec-2.5.6
8−- QuickCheck-2.12
9flags: {}
6flags: {}
10extra-package-dbs: []
7extra-package-dbs: []
test/Doctest.hsnew file+44
@@ -0,0 +1,44 @@
1+module Main where
2+
3+import Data.List (isPrefixOf)
4+import System.Directory
5+import System.FilePath
6+import System.FilePath.Find
7+import Test.DocTest
8+
9+main :: IO ()
10+main = do
11+ files <- find always (extension ==? ".hs") "src"
12+ mCabalMacrosFile <- getCabalMacrosFile
13+ doctest $ "-isrc" : "-Iinclude" :
14+ (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
15+ "-XOverloadedStrings" :
16+ "-XDeriveFunctor" :
17+ "-XFlexibleInstances" :
18+ "-XFlexibleContexts" :
19+ "-XMultiParamTypeClasses" :
20+ "-XDataKinds" :
21+ "-XTypeOperators" :
22+ "-XGADTs" :
23+ files
24+
25+getCabalMacrosFile :: IO (Maybe FilePath)
26+getCabalMacrosFile = do
27+ exists <- doesDirectoryExist "dist"
28+ if exists
29+ then do
30+ contents <- getDirectoryContents "dist"
31+ let rest = "build" </> "autogen" </> "cabal_macros.h"
32+ whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
33+ [x] -> "dist" </> x </> rest
34+ [] -> "dist" </> rest
35+ xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
36+ ++ show xs ++ "\nTry cabal clean"
37+ else return Nothing
38+ where
39+ whenExists :: FilePath -> IO (Maybe FilePath)
40+ whenExists file = do
41+ exists <- doesFileExist file
42+ return $ if exists
43+ then Just file
44+ else Nothing
test/Servant/QuickCheck/InternalSpec.hs+26−260
@@ -1,33 +1,19 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2module Servant.QuickCheck.InternalSpec (spec) where
2module Servant.QuickCheck.InternalSpec (spec) where
3
3
4−
5−import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
4+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
6−import Control.Exception (SomeException)
7−import Control.Monad (replicateM)
8−import Control.Monad.IO.Class (liftIO)
5+import Control.Monad.IO.Class (liftIO)
9−import qualified Data.ByteString as BS
10−import qualified Data.ByteString.Char8 as C
11−import Data.Maybe (fromJust)
12−import Network.HTTP.Client (path, queryString)
13−import Prelude.Compat
6+import Prelude.Compat
14−import Servant
7+import Servant
15−import Servant.HTML.Blaze (HTML)
8+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
16−import qualified Text.Blaze.Html as Blaze
17−import qualified Text.Blaze.Html5 as Blaze5
18−import Test.Hspec (Spec, context, describe, it, shouldBe,
9+import Test.Hspec (Spec, context, describe, it,
19− shouldContain)
10+ shouldBe, shouldContain)
20−import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
11+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
21− defaultParams, safeEvaluateExample)
12+ defaultParams,
22−import Test.QuickCheck.Gen (generate, unGen)
13+ evaluateExample)
23−import Test.QuickCheck.Random (mkQCGen)
24−
25−
26−import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
27
14
28import Servant.QuickCheck
15import Servant.QuickCheck
29−import Servant.QuickCheck.Internal (genRequest, runGenRequest,
16+import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
30− serverDoesntSatisfy)
31
17
32spec :: Spec
18spec :: Spec
33spec = do
19spec = do
@@ -35,12 +21,6 @@ spec = do
35 serverSatisfiesSpec
21 serverSatisfiesSpec
36 isComprehensiveSpec
22 isComprehensiveSpec
37 onlyJsonObjectSpec
23 onlyJsonObjectSpec
38− notLongerThanSpec
39− queryParamsSpec
40− queryFlagsSpec
41− deepPathSpec
42− htmlDocTypesSpec
43− unbiasedGenerationSpec
44
24
45serversEqualSpec :: Spec
25serversEqualSpec :: Spec
46serversEqualSpec = describe "serversEqual" $ do
26serversEqualSpec = describe "serversEqual" $ do
@@ -51,42 +31,15 @@ serversEqualSpec = describe "serversEqual" $ do
51 serversEqual api burl1 burl2 args bodyEquality
31 serversEqual api burl1 burl2 args bodyEquality
52
32
53 context "when servers are not equal" $ do
33 context "when servers are not equal" $ do
34+
35+
54 it "provides the failing responses in the error message" $ do
36 it "provides the failing responses in the error message" $ do
55− FailedWith err <- withServantServer api2 server2 $ \burl1 ->
37+ Fail _ err <- withServantServer api2 server2 $ \burl1 ->
56 withServantServer api2 server3 $ \burl2 -> do
38 withServantServer api2 server3 $ \burl2 -> do
57 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
39 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
58− show err `shouldContain` "Server equality failed"
59 show err `shouldContain` "Body: 1"
40 show err `shouldContain` "Body: 1"
60 show err `shouldContain` "Body: 2"
41 show err `shouldContain` "Body: 2"
61− show err `shouldContain` "Path: /failplz"
42+ show err `shouldContain` "Path: failplz/"
62−
63− context "when JSON is equal but looks a bit different as a ByteString" $ do
64−
65− it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
66− FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
67− withServantServer jsonApi jsonServer2 $ \burl2 -> do
68− evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
69− show err `shouldContain` "Server equality failed"
70−
71− it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
72− withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
73− withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
74− serversEqual jsonApi burl1 burl2 args jsonEquality
75−
76− it "sees when JSON apis are not equal because any value is different" $ do
77− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
78− withServantServer jsonApi jsonServer3 $ \burl2 -> do
79− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
80− show err `shouldContain` "Server equality failed"
81− show err `shouldContain` "Path: /jsonComparison"
82−
83− it "sees when JSON apis are not equal due to different keys but same values" $ do
84− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
85− withServantServer jsonApi jsonServer4 $ \burl2 -> do
86− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
87− show err `shouldContain` "Server equality failed"
88− show err `shouldContain` "Path: /jsonComparison"
89−
90
43
91serverSatisfiesSpec :: Spec
44serverSatisfiesSpec :: Spec
92serverSatisfiesSpec = describe "serverSatisfies" $ do
45serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -108,123 +61,29 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
108 context "when predicates are false" $ do
61 context "when predicates are false" $ do
109
62
110 it "fails with informative error messages" $ do
63 it "fails with informative error messages" $ do
111− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
64+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
112− evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
65+ evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
113− show err `shouldContain` "notAllowedContainsAllowHeader"
66+ err `shouldContain` "getsHaveCacheControlHeader"
114− show err `shouldContain` "Headers"
67+ err `shouldContain` "Headers"
115− show err `shouldContain` "Body"
68+ err `shouldContain` "Body"
116−
117
69
118onlyJsonObjectSpec :: Spec
70onlyJsonObjectSpec :: Spec
119onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
71onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
120
72
121 it "fails correctly" $ do
73 it "fails correctly" $ do
122− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
74+ Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
123 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
75 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
124 (onlyJsonObjects <%> mempty)
76 (onlyJsonObjects <%> mempty)
125− show err `shouldContain` "onlyJsonObjects"
77+ err `shouldContain` "onlyJsonObjects"
126−
127− it "accepts non-JSON endpoints" $ do
128− withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
129− serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
130−
131− it "does not fail when there is no content-type" $ do
132− withServantServerAndContext api2 ctx serverFailing $ \burl ->
133− serverSatisfies api2 burl args (onlyJsonObjects <%> mempty)
134
78
135−notLongerThanSpec :: Spec
136−notLongerThanSpec = describe "notLongerThan" $ do
137−
138− it "fails correctly" $ do
139− FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
140− evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
141− (notLongerThan 1 <%> mempty)
142− show err `shouldContain` "notLongerThan"
143−
144− it "succeeds correctly" $ do
145− withServantServerAndContext api ctx server $ \burl ->
146− serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)
147
79
148isComprehensiveSpec :: Spec
80isComprehensiveSpec :: Spec
149isComprehensiveSpec = describe "HasGenRequest" $ do
81isComprehensiveSpec = describe "HasGenRequest" $ do
150
82
151 it "has instances for all 'servant' combinators" $ do
83 it "has instances for all 'servant' combinators" $ do
152− let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
84+ let _g = genRequest comprehensiveAPIWithoutRaw
153 True `shouldBe` True -- This is a type-level check
85 True `shouldBe` True -- This is a type-level check
154
86
155−deepPathSpec :: Spec
156−deepPathSpec = describe "Path components" $ do
157−
158− it "are separated by slashes, without a trailing slash" $ do
159− let rng = mkQCGen 0
160− burl = BaseUrl Http "localhost" 80 ""
161− gen = runGenRequest deepAPI
162− req = (unGen gen rng 0) burl
163− path req `shouldBe` ("/one/two/three")
164−
165−
166−queryParamsSpec :: Spec
167−queryParamsSpec = describe "QueryParams" $ do
168−
169− it "reduce to an HTTP query string correctly" $ do
170− let rng = mkQCGen 0
171− burl = BaseUrl Http "localhost" 80 ""
172− gen = runGenRequest paramsAPI
173− req = (unGen gen rng 0) burl
174− qs = C.unpack $ queryString req
175− qs `shouldBe` "one=_&two=_"
176−
177−queryFlagsSpec :: Spec
178−queryFlagsSpec = describe "QueryFlags" $ do
179−
180− it "reduce to an HTTP query string correctly" $ do
181− let rng = mkQCGen 0
182− burl = BaseUrl Http "localhost" 80 ""
183− gen = runGenRequest flagsAPI
184− req = (unGen gen rng 0) burl
185− qs = C.unpack $ queryString req
186− qs `shouldBe` "one&two"
187−
188−htmlDocTypesSpec :: Spec
189−htmlDocTypesSpec = describe "HtmlDocTypes" $ do
190−
191− it "fails HTML without doctype correctly" $ do
192− err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
193− evalExample $ serverSatisfies docTypeApi burl args
194− (htmlIncludesDoctype <%> mempty)
195− show err `shouldContain` "htmlIncludesDoctype"
196−
197− it "passes HTML with a doctype at start" $ do
198− withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
199− serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
200−
201− it "accepts json endpoints and passes over them in silence" $ do
202− withServantServerAndContext api ctx server $ \burl -> do
203− serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
204− (htmlIncludesDoctype <%> mempty)
205−
206−
207−makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
208−makeRandomRequest large burl = do
209− req <- generate $ runGenRequest large
210− pure $ fst . fromJust . C.readInteger . C.drop 1 . path $ req burl
211−
212−
213−unbiasedGenerationSpec :: Spec
214−unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
215−
216− it "frequency paired with generated endpoint should be more randomly distributed" $ do
217− let burl = BaseUrl Http "localhost" 80 ""
218− let runs = 10000 :: Double
219− someRequests <- replicateM 10000 (makeRandomRequest largeApi burl)
220− let mean = (sum $ map fromIntegral someRequests) / runs
221− let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
222− let variance = (sum $ map variancer someRequests) / runs - 1
223− -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
224− mean > 8 `shouldBe` True
225− mean < 9 `shouldBe` True
226− -- Std dev is likely around 4. Variance is probably greater than 20.
227− variance > 19.5 `shouldBe` True
228
87
229------------------------------------------------------------------------------
88------------------------------------------------------------------------------
230-- APIs
89-- APIs
@@ -237,17 +96,6 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String
237api :: Proxy API
96api :: Proxy API
238api = Proxy
97api = Proxy
239
98
240−type ParamsAPI = QueryParam "one" () :> QueryParam "two" () :> Get '[JSON] ()
241−
242−paramsAPI :: Proxy ParamsAPI
243−paramsAPI = Proxy
244−
245−type FlagsAPI = QueryFlag "one" :> QueryFlag "two" :> Get '[JSON] ()
246−
247−flagsAPI :: Proxy FlagsAPI
248−flagsAPI = Proxy
249−
250−
251server :: IO (Server API)
99server :: IO (Server API)
252server = do
100server = do
253 mvar <- newMVar ""
101 mvar <- newMVar ""
@@ -261,105 +109,23 @@ type API2 = "failplz" :> Get '[JSON] Int
261api2 :: Proxy API2
109api2 :: Proxy API2
262api2 = Proxy
110api2 = Proxy
263
111
264−type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
265−
266−deepAPI :: Proxy DeepAPI
267−deepAPI = Proxy
268−
269−
270server2 :: IO (Server API2)
112server2 :: IO (Server API2)
271server2 = return $ return 1
113server2 = return $ return 1
272
114
273server3 :: IO (Server API2)
115server3 :: IO (Server API2)
274server3 = return $ return 2
116server3 = return $ return 2
275
117
276−serverFailing :: IO (Server API2)
277−serverFailing = return . throwError $ err405
278−
279−-- With Doctypes
280−type HtmlDoctype = Get '[HTML] Blaze.Html
281−
282−docTypeApi :: Proxy HtmlDoctype
283−docTypeApi = Proxy
284−
285−docTypeServer :: IO (Server HtmlDoctype)
286−docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
287−
288−noDocTypeServer :: IO (Server HtmlDoctype)
289−noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
290−
291−
292−-- Api for unbiased generation of requests tests
293−largeApi :: Proxy LargeAPI
294−largeApi = Proxy
295−
296−type LargeAPI
297− = "1" :> Get '[JSON] Int
298− :<|> "2" :> Get '[JSON] Int
299− :<|> "3" :> Get '[JSON] Int
300− :<|> "4" :> Get '[JSON] Int
301− :<|> "5" :> Get '[JSON] Int
302− :<|> "6" :> Get '[JSON] Int
303− :<|> "7" :> Get '[JSON] Int
304− :<|> "8" :> Get '[JSON] Int
305− :<|> "9" :> Get '[JSON] Int
306− :<|> "10" :> Get '[JSON] Int
307− :<|> "11" :> Get '[JSON] Int
308− :<|> "12" :> Get '[JSON] Int
309− :<|> "13" :> Get '[JSON] Int
310− :<|> "14" :> Get '[JSON] Int
311− :<|> "15" :> Get '[JSON] Int
312− :<|> "16" :> Get '[JSON] Int
313−
314−
315−type OctetAPI = Get '[OctetStream] BS.ByteString
316−
317−octetAPI :: Proxy OctetAPI
318−octetAPI = Proxy
319−
320−serverOctetAPI :: IO (Server OctetAPI)
321−serverOctetAPI = return $ return "blah"
322−
323−type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString
324−
325−jsonApi :: Proxy JsonApi
326−jsonApi = Proxy
327−
328−jsonServer1 :: IO (Server JsonApi)
329−jsonServer1 = return $ return "{ \"b\": [\"b\"], \"a\": 1 }" -- whitespace, ordering different
330−
331−jsonServer2 :: IO (Server JsonApi)
332−jsonServer2 = return $ return "{\"a\": 1,\"b\":[\"b\"]}"
333−
334−jsonServer3 :: IO (Server JsonApi)
335−jsonServer3 = return $ return "{\"a\": 2, \"b\": [\"b\"]}"
336−
337−jsonServer4 :: IO (Server JsonApi)
338−jsonServer4 = return $ return "{\"c\": 1, \"d\": [\"b\"]}"
339−
340−
341ctx :: Context '[BasicAuthCheck ()]
118ctx :: Context '[BasicAuthCheck ()]
342ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
119ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
343------------------------------------------------------------------------------
120------------------------------------------------------------------------------
344-- Utils
121-- Utils
345------------------------------------------------------------------------------
122------------------------------------------------------------------------------
123+
346−evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
124+evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
347−evalExample e = do
348− r <- safeEvaluateExample e defaultParams ($ ()) progCallback
125+evalExample e = evaluateExample e defaultParams ($ ()) progCallback
349− case resultStatus r of
350− Success -> return $ AllGood
351− Failure _ reason -> return $ FailedWith $ show reason
352− Pending {} -> error "should not happen"
353 where
126 where
354 progCallback _ = return ()
127 progCallback _ = return ()
355
128
356−data EvalResult
357− = AnException SomeException
358− | AllGood
359− | FailedWith String
360− deriving (Show)
361−
362−
363args :: Args
129args :: Args
364args = defaultArgs { maxSuccess = noOfTestCases }
130args = defaultArgs { maxSuccess = noOfTestCases }
365
131