git.iko.soy/servant-quickcheck
on master help sign in
swap
0535413109 ahead, 0 behind
.gitignore+1
since splitsnapshots
unifiedsplit
@@ -3,3 +3,4 @@ scripts/
3samples/
3samples/
4test-servers/
4test-servers/
5/doc/
5/doc/
6+.stack-work/
.travis.yml+154−30
@@ -1,34 +1,158 @@
1−sudo: false
1+# This Travis job script has been generated by a script via
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
3language: c
14language: c
4−
15+os: linux
5−env:
16+dist: xenial
6− - GHCVER=7.8.4
17+git:
7− - GHCVER=7.10.2
18+ # whether to recursively clone submodules
8−
19+ submodules: false
9−addons:
20+branches:
10− apt:
21+ only:
11− sources:
22+ - master
12− - hvr-ghc
23+cache:
13− packages:
24+ directories:
14− - ghc-7.8.4
25+ - $HOME/.cabal/packages
15− - ghc-7.10.2
26+ - $HOME/.cabal/store
16− - cabal-install-1.22
27+ - $HOME/.hlint
17− - libgmp-dev
28+before_cache:
18− - wrk
29+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
19−
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:
39+ - compiler: ghc-8.8.3
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"]}}
41+ os: linux
42+ - compiler: ghc-8.6.5
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"]}}
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
20install:
88install:
21− - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
89+ - ${CABAL} --version
22− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
90+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
23− - ghc --version
91+ - |
24− - cabal --version
92+ echo "program-default-options" >> $CABALHOME/config
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
25− - travis_retry cabal update
96+ - travis_retry ${CABAL} v2-update -v
26− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
97+ # Generate cabal.project
27−
98+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
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
28script:
114script:
29− - tinc && cabal configure --enable-tests && cabal build && cabal test
115+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
30− #- (cd doc && tinc cabal configure --enable-tests && cabal build && cabal test)
116+ # Packaging...
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
31
156
32−cache:
157+# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","servant-quickcheck.cabal"])
33− directories:
158+# EOF
34− - $HOME/.tinc/cache
CHANGELOG.yamlnew file+214
@@ -0,0 +1,214 @@
1+releases:
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+
172+
173+ - version: "0.0.2.0"
174+ changes:
175+
176+ - description: Update CHANGELOG to YAML syntax.
177+ pr: 16
178+ authors: jkarni
179+ date: 2016-09-14
180+
181+ - description: Support new CaptureAll combinator
182+ pr: 16
183+ authors: jkarni
184+ date: 2016-09-14
185+
186+ - description: Support GHC 8
187+ pr: 16
188+ authors: jkarni
189+ date: 2016-09-14
190+
191+ - version: "0.0.1.1"
192+ changes:
193+
194+ - description: Exclude GHC 7.8 (by bumping base lower bound to 4.8)
195+ pr: none
196+ authors: jkarni
197+
198+ - description: More generous bounds for other packages.
199+ pr: none
200+ authors: jkarni
201+
202+ - version: "0.0.1.0"
203+ changes:
204+
205+ - description: Better error messages.
206+ notes: >
207+ Error messages now contain failing predicate, failing response and
208+ (except for response predicates), failing requests.
209+ pr: none
210+ authors: jkarni
211+
212+ - description: Signicant changes to RequestPredicate and ResponsePredicate types.
213+ pr: none
214+ authors: jkarni
cabal.haskell-cinew file+7
@@ -0,0 +1,7 @@
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.projectnew file+4
@@ -0,0 +1,4 @@
1+packages: .
2+tests: true
3+
4+allow-newer: servant-blaze:servant
example/Main.hsnew file+31
@@ -0,0 +1,31 @@
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+126−87
@@ -1,99 +1,138 @@
1−name: servant-quickcheck
1+name: servant-quickcheck
2−version: 0.0.0.0
2+version: 0.0.9.1
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
16+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3
17+
18+source-repository head
19+ type: git
20+ location: https://github.com/haskell-servant/servant-quickcheck
15
21
16flag long-tests
22flag long-tests
17 description: Run more QuickCheck tests
23 description: Run more QuickCheck tests
18 default: False
24 default: False
19
25
20library
26library
21− exposed-modules: Servant.QuickCheck
27+ exposed-modules:
22− , Servant.QuickCheck.Internal
28+ Servant.QuickCheck
23− , Servant.QuickCheck.Internal.Predicates
29+ Servant.QuickCheck.Internal
24− , Servant.QuickCheck.Internal.HasGenRequest
25− , Servant.QuickCheck.Internal.QuickCheck
26− , Servant.QuickCheck.Internal.Equality
30+ Servant.QuickCheck.Internal.Equality
27− build-depends: base >=4.7 && <4.9
31+ Servant.QuickCheck.Internal.ErrorTypes
28− , base-compat == 0.9.*
32+ Servant.QuickCheck.Internal.HasGenRequest
29− , QuickCheck == 2.8.*
33+ Servant.QuickCheck.Internal.Predicates
30− , bytestring == 0.10.*
34+ Servant.QuickCheck.Internal.QuickCheck
35+
36+ build-depends:
31− , aeson > 0.10 && < 0.12
37+ aeson >=0.8 && <2
32− , mtl == 2.2.*
38+ , base >=4.9 && <4.15
33− , http-client == 0.4.*
39+ , base-compat-batteries >=0.10.1 && <0.12
34− , http-types == 0.9.*
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
35− , http-media == 0.6.*
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
36− , servant-client == 0.7.*
53+ , servant-client >=0.17 && <0.19
37− , servant-server == 0.7.*
54+ , servant-server >=0.17 && <0.19
55+ , split >=0.2 && <0.3
38− , string-conversions == 0.4.*
56+ , string-conversions >=0.3 && <0.5
39− , data-default-class == 0.0.*
40− , servant == 0.7.*
41− , warp >= 3.2.4 && < 3.3
42− , process == 1.2.*
43− , temporary == 1.2.*
57+ , temporary >=1.2 && <1.4
44− , split == 0.2.*
45− , case-insensitive == 1.2.*
46− , hspec == 2.2.*
47− , text == 1.*
58+ , text >=1 && <2
48− , pretty == 1.1.*
59+ , time >=1.5 && <1.11
60+ , warp >=3.2.4 && <3.4
61+
49− if impl(ghc < 7.10)
62+ if !impl(ghc >=8.0)
50− build-depends: bifunctors == 5.*
63+ build-depends: semigroups >=0.18.3 && <0.20
64+
65+ hs-source-dirs: src
66+ default-extensions:
67+ NoImplicitPrelude
68+ ConstraintKinds
69+ DataKinds
70+ DeriveDataTypeable
71+ DeriveFunctor
72+ DeriveGeneric
73+ FlexibleContexts
74+ FlexibleInstances
75+ FunctionalDependencies
76+ GADTs
77+ KindSignatures
78+ MultiParamTypeClasses
79+ OverloadedStrings
80+ RankNTypes
81+ ScopedTypeVariables
82+ TypeOperators
51
83
52− hs-source-dirs: src
53− default-extensions: TypeOperators
54− , FlexibleInstances
55− , FlexibleContexts
56− , DataKinds
57− , GADTs
58− , MultiParamTypeClasses
59− , DeriveFunctor
60− , KindSignatures
61− , RankNTypes
62− , ConstraintKinds
63− , DeriveGeneric
64− , ScopedTypeVariables
65− , OverloadedStrings
66− , FunctionalDependencies
67− , NoImplicitPrelude
68− default-language: Haskell2010
84+ default-language: Haskell2010
69
85
70test-suite spec
86test-suite spec
71− type: exitcode-stdio-1.0
87+ type: exitcode-stdio-1.0
72− ghc-options: -Wall -threaded
88+ ghc-options: -Wall -threaded
73− default-language: Haskell2010
89+ default-language: Haskell2010
74− hs-source-dirs: test
90+ hs-source-dirs: test
75− main-is: Spec.hs
91+ main-is: Spec.hs
76− other-modules: Servant.QuickCheck.InternalSpec
92+ other-modules: Servant.QuickCheck.InternalSpec
77− build-depends: base == 4.*
93+ build-tool-depends: hspec-discover:hspec-discover -any
94+ build-depends:
95+ aeson
96+ , base
78− , base-compat
97+ , base-compat-batteries
79− , servant-quickcheck
98+ , blaze-html
99+ , bytestring
80− , hspec
100+ , hspec
81− , hspec-core
101+ , hspec-core >=2.5.5 && <2.8
82− , http-client
102+ , http-client
83− , warp
103+ , QuickCheck
104+ , quickcheck-io
105+ , servant
106+ , servant-blaze
107+ , servant-client
108+ , servant-quickcheck
84− , servant-server
109+ , servant-server
85− , servant-client
86− , servant
87− , transformers
110+ , transformers
88− , QuickCheck
111+ , warp
89− , quickcheck-io
112+
90− default-extensions: TypeOperators
113+ default-extensions:
91− , FlexibleInstances
114+ NoImplicitPrelude
115+ DataKinds
92− , FlexibleContexts
116+ FlexibleContexts
117+ FlexibleInstances
93− , GADTs
118+ GADTs
94− , DataKinds
95− , NoImplicitPrelude
96− , OverloadedStrings
119+ OverloadedStrings
97− , ScopedTypeVariables
120+ ScopedTypeVariables
121+ TypeOperators
122+
98 if flag(long-tests)
123 if flag(long-tests)
99− cpp-options: -DLONG_TESTS
124+ 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+10−3
@@ -27,12 +27,18 @@ 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
30 , onlyJsonObjects
31 , onlyJsonObjects
32+ , honoursAcceptHeader
31 , notAllowedContainsAllowHeader
33 , notAllowedContainsAllowHeader
32 , unauthorizedContainsWWWAuthenticate
34 , unauthorizedContainsWWWAuthenticate
35+ , getsHaveLastModifiedHeader
33 , getsHaveCacheControlHeader
36 , getsHaveCacheControlHeader
34 , headsHaveCacheControlHeader
37 , headsHaveCacheControlHeader
35 , createContainsValidLocation
38 , createContainsValidLocation
39+ -- * Html Predicates
40+ , htmlIncludesDoctype
41+
36 -- *** Predicate utilities and types
42 -- *** Predicate utilities and types
37 , (<%>)
43 , (<%>)
38 , Predicates
44 , Predicates
@@ -48,6 +54,7 @@ module Servant.QuickCheck
48 -- represents other means of checking equality
54 -- represents other means of checking equality
49 -- *** Useful @ResponseEquality@s
55 -- *** Useful @ResponseEquality@s
50 , bodyEquality
56 , bodyEquality
57+ , jsonEquality
51 , allEquality
58 , allEquality
52 -- ** Response equality type
59 -- ** Response equality type
53 , ResponseEquality(..)
60 , ResponseEquality(..)
@@ -69,10 +76,10 @@ module Servant.QuickCheck
69
76
70 ) where
77 ) where
71
78
79+import Data.Proxy (Proxy (..))
80+import Servant.Client (BaseUrl (..), Scheme (..))
72import Servant.QuickCheck.Internal
81import Servant.QuickCheck.Internal
73−import Servant.Client (BaseUrl(..), Scheme(..))
74−import Test.QuickCheck (Args(..), stdArgs)
82+import Test.QuickCheck (Args (..), stdArgs)
75−import Data.Proxy (Proxy(..))
76
83
77-- | QuickCheck @Args@ with 1000 rather than 100 test cases.
84-- | QuickCheck @Args@ with 1000 rather than 100 test cases.
78--
85--
src/Servant/QuickCheck/Internal.hs+4−3
@@ -1,6 +1,7 @@
1module Servant.QuickCheck.Internal (module X) where
1module Servant.QuickCheck.Internal (module X) where
2
2
3+import Servant.QuickCheck.Internal.Equality as X
4+import Servant.QuickCheck.Internal.ErrorTypes as X
3import Servant.QuickCheck.Internal.HasGenRequest as X
5import Servant.QuickCheck.Internal.HasGenRequest as X
4−import Servant.QuickCheck.Internal.Predicates as X
6+import Servant.QuickCheck.Internal.Predicates as X
5−import Servant.QuickCheck.Internal.QuickCheck as X
7+import Servant.QuickCheck.Internal.QuickCheck as X
6−import Servant.QuickCheck.Internal.Equality as X
src/Servant/QuickCheck/Internal/Equality.hs+38−5
@@ -1,16 +1,23 @@
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
3−import Data.Function (on)
6+import Data.Function (on)
4−import Network.HTTP.Client (Response, responseBody)
7+import Network.HTTP.Client (Response, responseBody)
8+import Data.Semigroup (Semigroup (..))
5−import Prelude.Compat
9+import Prelude.Compat
6
10
7newtype ResponseEquality b
11newtype ResponseEquality b
8 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
12 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
9
13
14+instance Semigroup (ResponseEquality b) where
15+ ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y ->
16+ a x y && b x y
17+
10instance Monoid (ResponseEquality b) where
18instance Monoid (ResponseEquality b) where
11 mempty = ResponseEquality $ \_ _ -> True
19 mempty = ResponseEquality $ \_ _ -> True
12− ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->
20+ mappend = (<>)
13− a x y && b x y
14
21
15-- | Use `Eq` instance for `Response`
22-- | Use `Eq` instance for `Response`
16--
23--
@@ -23,3 +30,29 @@ allEquality = ResponseEquality (==)
23-- /Since 0.0.0.0/
30-- /Since 0.0.0.0/
24bodyEquality :: Eq b => ResponseEquality b
31bodyEquality :: Eq b => ResponseEquality b
25bodyEquality = ResponseEquality ((==) `on` responseBody)
32bodyEquality = 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+77−32
@@ -1,37 +1,82 @@
1+{-# LANGUAGE CPP #-}
1module Servant.QuickCheck.Internal.ErrorTypes where
2module Servant.QuickCheck.Internal.ErrorTypes where
2
3
4+import Control.Exception (Exception (..))
5+import qualified Data.ByteString.Lazy as LBS
6+import Data.String.Conversions (cs)
7+import qualified Data.Text as T
8+import Data.Typeable (Typeable)
9+import GHC.Generics (Generic)
10+import qualified Network.HTTP.Client as C
11+import Network.HTTP.Types (Header, statusCode)
3−import Text.PrettyPrint
12+import Text.PrettyPrint
4
13
5−data Request = Request
14+import Prelude.Compat hiding ((<>))
6− { requestBody :: String
7− , requestHeaders :: [String]
8− , requestUrl :: String
9− } deriving (Eq, Show, Read, Generic)
10
15
16+data PredicateFailure
17+ = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
18+ deriving (Typeable, Generic)
19+
20+instance Exception ServerEqualityFailure where
21+
22+instance Show PredicateFailure where
23+ show = render . prettyPredicateFailure
24+
25+
26+data ServerEqualityFailure
27+ = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)
28+ deriving (Typeable, Generic)
29+
30+instance Show ServerEqualityFailure where
31+ show = render . prettyServerEqualityFailure
32+
33+
34+instance Exception PredicateFailure where
35+
36+-- * Pretty printing
37+
38+prettyHeaders :: [Header] -> Doc
39+prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs
40+ where
41+ prettyHdr (hn, h) = text (show hn) <> colon <+> text (show h)
42+
11−prettyReq :: Doc
43+prettyReq :: C.Request -> Doc
12prettyReq r =
44prettyReq r =
13− text "Request:" $ nest 5 $
45+ text "Request:" $$ (nest 5 $
14− text "URL:" <+> text (nest 5 $ requestUrl r)
46+ text "Method:" <+> (nest 5 $ text . show $ C.method r)
15− $$ text "Headers:" <+>
47+ $$ text "Path:" <+> (nest 5 $ text . cs $ C.path r)
48+ $$ text "Headers:" <+> (nest 5 $ prettyHeaders $ C.requestHeaders r)
16− $$ text "Body:" <+> text (nest 5 $ requestBody r)
49+ $$ text "Body:" <+> (nest 5 $ text . getReqBody $ C.requestBody r))
17−
50+ where
18−instance IsString Request where
51+ getReqBody (C.RequestBodyLBS lbs ) = cs lbs
19− fromString url = Request "" [] url
52+ getReqBody (C.RequestBodyBS bs ) = cs bs
20−
53+ getReqBody _ = error "expected bytestring body"
54+
55+prettyResp :: C.Response LBS.ByteString -> Doc
56+prettyResp r =
21−data Response = Response
57+ text "Response:" $$ (nest 5 $
22− { responseBody :: String
58+ text "Status code:" <+> (nest 5 $ text . show . statusCode $ C.responseStatus r)
23− , responseHeaders :: [String]
59+ $$ text "Headers:" $$ (nest 10 $ prettyHeaders $ C.responseHeaders r)
24− } deriving (Eq, Show, Read, Generic)
60+ $$ text "Body:" <+> (nest 5 $ text . cs $ C.responseBody r))
25−
61+
26−instance IsString Response where
62+
27− fromString body = Response body []
63+
28−
64+prettyServerEqualityFailure :: ServerEqualityFailure -> Doc
29−-- The error that occurred.
65+prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =
30−data Failure
66+ text "Server equality failed" $$ (nest 5 $
31− = PredicateFailure String Request Response
67+ prettyReq req
32− | ServerEqualityFailure Request Response Response
68+ $$ prettyResp resp1
33− deriving (Eq, Show, Read, Generic)
69+ $$ prettyResp resp2)
34−
70+
35−instance Show Failure where
71+
36− show (PredicateFailure pred req resp)
72+prettyPredicateFailure :: PredicateFailure -> Doc
37− = "Predicate failed for " <> pred <> "
73+prettyPredicateFailure (PredicateFailure predicate req resp) =
74+ text "Predicate failed" $$ (nest 5 $
75+ text "Predicate:" <+> (text $ T.unpack predicate)
76+ $$ r
77+ $$ prettyResp resp)
78+ where
79+ r = case req of
80+ Nothing -> text ""
81+ Just v -> prettyReq v
82+
src/Servant/QuickCheck/Internal/HasGenRequest.hs+113−53
@@ -1,98 +1,148 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE PolyKinds #-}
2{-# LANGUAGE PolyKinds #-}
2module Servant.QuickCheck.Internal.HasGenRequest where
3module Servant.QuickCheck.Internal.HasGenRequest where
3
4
4−import Data.Default.Class (def)
5−import Data.Monoid ((<>))
6−import Data.String (fromString)
5+import Data.String (fromString)
7−import Data.String.Conversions (cs)
6+import Data.String.Conversions (cs)
8−import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
7+import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
9−import Network.HTTP.Client (Request, RequestBody (..), host,
8+import Network.HTTP.Client (Request, RequestBody (..), host, method, path,
10− method, path, port, queryString,
11− requestBody, requestHeaders, secure)
9+ port, queryString, requestBody, requestHeaders,
10+ secure, defaultRequest)
12−import Network.HTTP.Media (renderHeader)
11+import Network.HTTP.Media (renderHeader)
13−import Prelude.Compat
12+import Prelude.Compat
14−import Servant
13+import Servant
15−import Servant.API.ContentTypes (AllMimeRender (..))
14+import Servant.API.ContentTypes (AllMimeRender (..))
16−import Servant.Client (BaseUrl (..), Scheme (..))
15+import Servant.Client (BaseUrl (..), Scheme (..))
17−import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)
16+import Test.QuickCheck (Arbitrary (..), Gen, elements, frequency)
18−
17+
19−
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+
34+-- -----------------------------------------------------------------------------
35+-- HasGenRequest
36+
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.
20class HasGenRequest a where
42class HasGenRequest a where
21− genRequest :: Proxy a -> Gen (BaseUrl -> Request)
43+ genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))
44+
22
45
23instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
46instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
24 genRequest _
47 genRequest _
48+ = (lf + rf, frequency [l, r])
49+ where
25− = oneof [ genRequest (Proxy :: Proxy a)
50+ l@(lf, _) = genRequest (Proxy :: Proxy a)
26− , genRequest (Proxy :: Proxy b)
51+ r@(rf, _) = genRequest (Proxy :: Proxy b)
27− ]
52+
28
53
29instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
54instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
30− genRequest _ = do
55+ genRequest _ = (oldf, do
31 old' <- old
56 old' <- old
32− return $ \burl -> let r = old' burl in r { path = new <> "/" <> path r }
57+ return $ \burl -> let r = old' burl
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 })
33 where
62 where
34− old = genRequest (Proxy :: Proxy b)
63+ (oldf, old) = genRequest (Proxy :: Proxy b)
35 new = cs $ symbolVal (Proxy :: Proxy path)
64 new = cs $ symbolVal (Proxy :: Proxy path)
36
65
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+
37instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
75instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
38− => HasGenRequest (Capture x c :> b) where
76+ => HasGenRequest (Capture' mods x c :> b) where
39− genRequest _ = do
77+ genRequest _ = (oldf, do
40 old' <- old
78 old' <- old
41 new' <- toUrlPiece <$> new
79 new' <- toUrlPiece <$> new
42− return $ \burl -> let r = old' burl in r { path = cs new' <> "/" <> path r }
80+ return $ \burl -> let r = old' burl in r { path = cs new' <> path r })
43 where
81 where
44− old = genRequest (Proxy :: Proxy b)
82+ (oldf, old) = genRequest (Proxy :: Proxy b)
45 new = arbitrary :: Gen c
83 new = arbitrary :: Gen c
46
84
85+instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
86+ => HasGenRequest (CaptureAll x c :> b) where
87+ genRequest _ = (oldf, do
88+ old' <- old
89+ new' <- fmap (cs . toUrlPiece) <$> new
90+ let new'' = BS.intercalate "/" new'
91+ return $ \burl -> let r = old' burl in r { path = new'' <> path r })
92+ where
93+ (oldf, old) = genRequest (Proxy :: Proxy b)
94+ new = arbitrary :: Gen [c]
95+
47instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
96instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
48− => HasGenRequest (Header h c :> b) where
97+ => HasGenRequest (Header' mods h c :> b) where
49− genRequest _ = do
98+ genRequest _ = (oldf, do
50 old' <- old
99 old' <- old
51− new' <- toUrlPiece <$> new
100+ new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
52 return $ \burl -> let r = old' burl in r {
101 return $ \burl -> let r = old' burl in r {
53− requestHeaders = (hdr, cs new') : requestHeaders r }
102+ requestHeaders = (hdr, cs new') : requestHeaders r })
54 where
103 where
55− old = genRequest (Proxy :: Proxy b)
104+ (oldf, old) = genRequest (Proxy :: Proxy b)
56 hdr = fromString $ symbolVal (Proxy :: Proxy h)
105 hdr = fromString $ symbolVal (Proxy :: Proxy h)
57 new = arbitrary :: Gen c
106 new = arbitrary :: Gen c
58
107
59instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
108instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
60− => HasGenRequest (ReqBody x c :> b) where
109+ => HasGenRequest (ReqBody' mods x c :> b) where
61− genRequest _ = do
110+ genRequest _ = (oldf, do
62− old' <- old
111+ old' <- old -- TODO: generate lenient
63 new' <- new
112 new' <- new
64 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
113 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
65 return $ \burl -> let r = old' burl in r {
114 return $ \burl -> let r = old' burl in r {
66 requestBody = RequestBodyLBS bd
115 requestBody = RequestBodyLBS bd
67 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
116 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
68− }
117+ })
69 where
118 where
70− old = genRequest (Proxy :: Proxy b)
119+ (oldf, old) = genRequest (Proxy :: Proxy b)
71 new = arbitrary :: Gen c
120 new = arbitrary :: Gen c
72
121
73instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
122instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
74− => HasGenRequest (QueryParam x c :> b) where
123+ => HasGenRequest (QueryParam' mods x c :> b) where
75− genRequest _ = do
124+ genRequest _ = (oldf, do
76− new' <- new
125+ new' <- new -- TODO: generate lenient or/and optional
77 old' <- old
126 old' <- old
78− return $ \burl -> let r = old' burl in r {
127+ return $ \burl -> let r = old' burl
79− queryString = queryString r
80− <> param <> "=" <> cs (toQueryParam new') }
128+ newExpr = param <> "=" <> cs (toQueryParam new')
129+ qs = queryString r in r {
130+ queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
81 where
131 where
82− old = genRequest (Proxy :: Proxy b)
132+ (oldf, old) = genRequest (Proxy :: Proxy b)
83 param = cs $ symbolVal (Proxy :: Proxy x)
133 param = cs $ symbolVal (Proxy :: Proxy x)
84 new = arbitrary :: Gen c
134 new = arbitrary :: Gen c
85
135
86instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
136instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
87 => HasGenRequest (QueryParams x c :> b) where
137 => HasGenRequest (QueryParams x c :> b) where
88− genRequest _ = do
138+ genRequest _ = (oldf, do
89 new' <- new
139 new' <- new
90 old' <- old
140 old' <- old
91 return $ \burl -> let r = old' burl in r {
141 return $ \burl -> let r = old' burl in r {
92 queryString = queryString r
142 queryString = queryString r
93− <> if length new' > 0 then fold (toParam <$> new') else ""}
143+ <> if length new' > 0 then fold (toParam <$> new') else ""})
94 where
144 where
95− old = genRequest (Proxy :: Proxy b)
145+ (oldf, old) = genRequest (Proxy :: Proxy b)
96 param = cs $ symbolVal (Proxy :: Proxy x)
146 param = cs $ symbolVal (Proxy :: Proxy x)
97 new = arbitrary :: Gen [c]
147 new = arbitrary :: Gen [c]
98 toParam c = param <> "[]=" <> cs (toQueryParam c)
148 toParam c = param <> "[]=" <> cs (toQueryParam c)
@@ -100,22 +150,32 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
100
150
101instance (KnownSymbol x, HasGenRequest b)
151instance (KnownSymbol x, HasGenRequest b)
102 => HasGenRequest (QueryFlag x :> b) where
152 => HasGenRequest (QueryFlag x :> b) where
103− genRequest _ = do
153+ genRequest _ = (oldf, do
104 old' <- old
154 old' <- old
105− return $ \burl -> let r = old' burl in r {
155+ return $ \burl -> let r = old' burl
156+ qs = queryString r in r {
106− queryString = queryString r <> param <> "=" }
157+ queryString = if BS.null qs then param else param <> "&" <> qs })
107 where
158 where
108− old = genRequest (Proxy :: Proxy b)
159+ (oldf, old) = genRequest (Proxy :: Proxy b)
109 param = cs $ symbolVal (Proxy :: Proxy x)
160 param = cs $ symbolVal (Proxy :: Proxy x)
110
161
111instance (ReflectMethod method)
162instance (ReflectMethod method)
112 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
163 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
113− genRequest _ = return $ \burl -> def
164+ genRequest _ = (1, return $ \burl -> defaultRequest
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
114 { host = cs $ baseUrlHost burl
174 { host = cs $ baseUrlHost burl
115 , port = baseUrlPort burl
175 , port = baseUrlPort burl
116 , secure = baseUrlScheme burl == Https
176 , secure = baseUrlScheme burl == Https
117 , method = reflectMethod (Proxy :: Proxy method)
177 , method = reflectMethod (Proxy :: Proxy method)
118− }
178+ })
119
179
120instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
180instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
121 genRequest _ = genRequest (Proxy :: Proxy a)
181 genRequest _ = genRequest (Proxy :: Proxy a)
src/Servant/QuickCheck/Internal/Predicates.hs+218−134
@@ -1,28 +1,36 @@
1module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
2
2
3−import Control.Monad (liftM2)
3+import Control.Exception (catch, throw)
4+import Control.Monad (liftM2, unless, when)
4import Data.Aeson (Object, decode)
5import Data.Aeson (Object, decode)
5−import Data.Bifunctor (Bifunctor (..))
6+import Data.Bifunctor (first)
6−import Prelude.Compat
7import qualified Data.ByteString as SBS
7import qualified Data.ByteString as SBS
8import qualified Data.ByteString.Char8 as SBSC
8import qualified Data.ByteString.Char8 as SBSC
9import qualified Data.ByteString.Lazy as LBS
9import qualified Data.ByteString.Lazy as LBS
10−import Data.CaseInsensitive (mk)
10+import Data.CaseInsensitive (foldCase, foldedCase, mk)
11import Data.Either (isRight)
11import Data.Either (isRight)
12import Data.List.Split (wordsBy)
12import Data.List.Split (wordsBy)
13import Data.Maybe (fromMaybe, isJust)
13import Data.Maybe (fromMaybe, isJust)
14−import Data.Monoid ((<>))
14+import Data.Semigroup (Semigroup (..))
15−import Data.Text (Text)
15+import qualified Data.Text as T
16+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
17+ rfc822DateFormat)
16import GHC.Generics (Generic)
18import GHC.Generics (Generic)
17import Network.HTTP.Client (Manager, Request, Response, httpLbs,
19import Network.HTTP.Client (Manager, Request, Response, httpLbs,
18− method, parseUrl, requestHeaders,
20+ method, parseRequest, requestHeaders,
19 responseBody, responseHeaders,
21 responseBody, responseHeaders,
20 responseStatus)
22 responseStatus)
21import Network.HTTP.Media (matchAccept)
23import Network.HTTP.Media (matchAccept)
22import Network.HTTP.Types (methodGet, methodHead, parseMethod,
24import Network.HTTP.Types (methodGet, methodHead, parseMethod,
23− renderStdMethod, status200, status201,
25+ renderStdMethod, status100, status200,
24− status300, status401, status405,
26+ status201, status300, status401,
25− status500, status100)
27+ status405, status500)
28+import Prelude.Compat
29+import System.Clock (Clock (Monotonic), diffTimeSpec,
30+ getTime, toNanoSecs)
31+
32+import Servant.QuickCheck.Internal.ErrorTypes
33+
26
34
27-- | [__Best Practice__]
35-- | [__Best Practice__]
28--
36--
@@ -33,8 +41,25 @@ import Network.HTTP.Types (methodGet, methodHead, parseMethod,
33-- This function checks that the response code is not 500.
41-- This function checks that the response code is not 500.
34--
42--
35-- /Since 0.0.0.0/
43-- /Since 0.0.0.0/
36−not500 :: ResponsePredicate Text Bool
44+not500 :: ResponsePredicate
37−not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == status500)
45+not500 = ResponsePredicate $ \resp ->
46+ when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
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 []
38
63
39-- | [__Best Practice__]
64-- | [__Best Practice__]
40--
65--
@@ -57,11 +82,15 @@ not500 = ResponsePredicate "not500" (\resp -> not $ responseStatus resp == statu
57-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
82-- * JSON Grammar: <https://tools.ietf.org/html/rfc4627#section-2 RFC 4627 Section 2>
58--
83--
59-- /Since 0.0.0.0/
84-- /Since 0.0.0.0/
60−onlyJsonObjects :: ResponsePredicate Text Bool
85+onlyJsonObjects :: ResponsePredicate
61onlyJsonObjects
86onlyJsonObjects
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
62− = ResponsePredicate "onlyJsonObjects" (\resp -> case decode (responseBody resp) of
91+ case (decode (responseBody resp) :: Maybe Object) of
63− Nothing -> False
92+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
64− Just (_ :: Object) -> True)
93+ Just _ -> return ())
65
94
66-- | __Optional__
95-- | __Optional__
67--
96--
@@ -82,29 +111,59 @@ onlyJsonObjects
82-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
111-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
83--
112--
84-- /Since 0.0.0.0/
113-- /Since 0.0.0.0/
85−createContainsValidLocation :: RequestPredicate Text Bool
114+createContainsValidLocation :: RequestPredicate
86createContainsValidLocation
115createContainsValidLocation
87− = RequestPredicate
116+ = RequestPredicate $ \req mgr -> do
88− { reqPredName = "createContainsValidLocation"
117+ let n = "createContainsValidLocation"
89− , reqResps = \req mgr -> do
118+ resp <- httpLbs req mgr
119+ if responseStatus resp == status201
120+ then case lookup "Location" $ responseHeaders resp of
121+ Nothing -> throw $ PredicateFailure n (Just req) resp
122+ Just l -> case parseRequest $ SBSC.unpack l of
123+ Nothing -> throw $ PredicateFailure n (Just req) resp
124+ Just x -> do
125+ resp2 <- httpLbs x mgr
126+ status2XX (Just req) resp2 n
127+ return [resp, resp2]
128+ else return [resp]
129+
130+-- | [__Optional__]
131+--
132+-- The @Last-Modified@ header represents the time a resource was last
133+-- modified. It is used to drive caching and conditional requests.
134+--
135+-- When using this mechanism, the server adds the @Last-Modified@ header to
136+-- responses. Clients may then make requests with the @If-Modified-Since@
137+-- header to conditionally request resources. If the resource has not
138+-- changed since that date, the server responds with a status code of 304
139+-- (@Not Modified@) without a response body.
140+--
141+-- The @Last-Modified@ header can also be used in conjunction with the
142+-- @If-Unmodified-Since@ header to drive optimistic concurrency.
143+--
144+-- The @Last-Modified@ date must be in RFC 822 format.
145+--
146+-- __References__:
147+--
148+-- * 304 Not Modified: <https://tools.ietf.org/html/rfc7232#section-4.1 RFC 7232 Section 4.1>
149+-- * Last-Modified header: <https://tools.ietf.org/html/rfc7232#section-2.2 RFC 7232 Section 2.2>
150+-- * If-Modified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.3 RFC 7232 Section 3.3>
151+-- * 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>
153+--
154+-- /Since 0.0.2.1/
155+getsHaveLastModifiedHeader :: RequestPredicate
156+getsHaveLastModifiedHeader
157+ = RequestPredicate $ \req mgr ->
158+ if (method req == methodGet)
159+ then do
90 resp <- httpLbs req mgr
160 resp <- httpLbs req mgr
91− if responseStatus resp == status201
161+ unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
92− then case lookup "Location" $ responseHeaders resp of
162+ throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
93− Nothing -> return (False, [resp])
94− Just l -> case parseUrl $ SBSC.unpack l of
95− Nothing -> return (False, [resp])
96− Just x -> do
97− resp2 <- httpLbs x mgr
98− return (status2XX resp2, [resp, resp2])
163+ return [resp]
99− else return (True, [resp])
164+ else return []
100− }
101
165
102−{-
103−getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
104−getsHaveLastModifiedHeader
105− = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
106
166
107−-}
108
167
109-- | [__RFC Compliance__]
168-- | [__RFC Compliance__]
110--
169--
@@ -116,24 +175,27 @@ getsHaveLastModifiedHeader
116-- This function checks that every @405 Method Not Allowed@ response contains
175-- This function checks that every @405 Method Not Allowed@ response contains
117-- an @Allow@ header with a list of standard HTTP methods.
176-- an @Allow@ header with a list of standard HTTP methods.
118--
177--
178+-- Note that 'servant' itself does not currently set the @Allow@ headers.
179+--
119-- __References__:
180-- __References__:
120--
181--
121-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
182-- * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
122-- * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
183-- * 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>
123--
185--
124-- /Since 0.0.0.0/
186-- /Since 0.0.0.0/
125−notAllowedContainsAllowHeader :: RequestPredicate Text Bool
187+notAllowedContainsAllowHeader :: RequestPredicate
126notAllowedContainsAllowHeader
188notAllowedContainsAllowHeader
127− = RequestPredicate
189+ = RequestPredicate $ \req mgr -> do
128− { reqPredName = "notAllowedContainsAllowHeader"
129− , reqResps = \req mgr -> do
130− resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
190+ let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
131− | m <- [minBound .. maxBound ]
132− , renderStdMethod m /= method req ]
191+ , renderStdMethod m /= method req ]
133− return (all pred' resp, resp)
192+ resp <- mapM (flip httpLbs mgr) reqs
134− }
193+
194+ case filter pred' (zip reqs resp) of
195+ (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
196+ [] -> return resp
135 where
197 where
136− pred' resp = responseStatus resp /= status405 || hasValidHeader "Allow" go resp
198+ pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
137 where
199 where
138 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
139 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -154,19 +216,19 @@ notAllowedContainsAllowHeader
154-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
216-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
155--
217--
156-- /Since 0.0.0.0/
218-- /Since 0.0.0.0/
157−honoursAcceptHeader :: RequestPredicate Text Bool
219+honoursAcceptHeader :: RequestPredicate
158honoursAcceptHeader
220honoursAcceptHeader
159− = RequestPredicate
221+ = RequestPredicate $ \req mgr -> do
160− { reqPredName = "honoursAcceptHeader"
161− , reqResps = \req mgr -> do
162− resp <- httpLbs req mgr
222+ resp <- httpLbs req mgr
163− let scode = responseStatus resp
223+ let scode = responseStatus resp
164− sctype = lookup "Content-Type" $ responseHeaders resp
224+ sctype = lookup "Content-Type" $ responseHeaders resp
165− sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
225+ sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
166− if status100 < scode && scode < status300
226+ if status100 < scode && scode < status300
167− then return (isJust $ sctype >>= \x -> matchAccept [x] sacc, [resp])
227+ then if isJust $ sctype >>= \x -> matchAccept [x] sacc
228+ then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
168− else return (True, [resp])
229+ else return [resp]
169− }
230+ else return [resp]
231+
170
232
171-- | [__Best Practice__]
233-- | [__Best Practice__]
172--
234--
@@ -182,34 +244,32 @@ honoursAcceptHeader
182-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
244-- * @Cache-Control@ header: <https://tools.ietf.org/html/rfc7234#section-5.2 RFC 7234 Section 5.2>
183--
245--
184-- /Since 0.0.0.0/
246-- /Since 0.0.0.0/
185−getsHaveCacheControlHeader :: RequestPredicate Text Bool
247+getsHaveCacheControlHeader :: RequestPredicate
186getsHaveCacheControlHeader
248getsHaveCacheControlHeader
187− = RequestPredicate
249+ = RequestPredicate $ \req mgr ->
188− { reqPredName = "getsHaveCacheControlHeader"
189− , reqResps = \req mgr -> if method req == methodGet
250+ if (method req == methodGet)
190− then do
251+ then do
191− resp <- httpLbs req mgr
252+ resp <- httpLbs req mgr
192− let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
253+ unless (hasValidHeader "Cache-Control" (const True) resp) $ do
193− return (good, [resp])
254+ throw $ PredicateFailure "getsHaveCacheControlHeader" (Just req) resp
194− else return (True, [])
255+ return [resp]
195− }
256+ else return []
196
257
197-- | [__Best Practice__]
258-- | [__Best Practice__]
198--
259--
199-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
260-- Like 'getsHaveCacheControlHeader', but for @HEAD@ requests.
200--
261--
201-- /Since 0.0.0.0/
262-- /Since 0.0.0.0/
202−headsHaveCacheControlHeader :: RequestPredicate Text Bool
263+headsHaveCacheControlHeader :: RequestPredicate
203headsHaveCacheControlHeader
264headsHaveCacheControlHeader
204− = RequestPredicate
265+ = RequestPredicate $ \req mgr ->
205− { reqPredName = "headsHaveCacheControlHeader"
206− , reqResps = \req mgr -> if method req == methodHead
266+ if (method req == methodHead)
207− then do
267+ then do
208− resp <- httpLbs req mgr
268+ resp <- httpLbs req mgr
209− let good = hasValidHeader "Cache-Control" (const True) resp
269+ unless (hasValidHeader "Cache-Control" (const True) resp) $
210− return (good, [resp])
270+ throw $ PredicateFailure "headsHaveCacheControlHeader" (Just req) resp
271+ return [resp]
211− else return (True, [])
272+ else return []
212− }
213{-
273{-
214-- |
274-- |
215--
275--
@@ -271,12 +331,35 @@ linkHeadersAreValid
271-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
331-- * @WWW-Authenticate@ header: <https://tools.ietf.org/html/rfc7235#section-4.1 RFC 7235 Section 4.1>
272--
332--
273-- /Since 0.0.0.0/
333-- /Since 0.0.0.0/
274−unauthorizedContainsWWWAuthenticate :: ResponsePredicate Text Bool
334+unauthorizedContainsWWWAuthenticate :: ResponsePredicate
275unauthorizedContainsWWWAuthenticate
335unauthorizedContainsWWWAuthenticate
276− = ResponsePredicate "unauthorizedContainsWWWAuthenticate" (\resp ->
336+ = ResponsePredicate $ \resp ->
277 if responseStatus resp == status401
337 if responseStatus resp == status401
278− then hasValidHeader "WWW-Authenticate" (const True) resp
338+ then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339+ throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
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
279− else True)
362+ else return ()
280
363
281-- * Predicate logic
364-- * Predicate logic
282
365
@@ -289,67 +372,56 @@ unauthorizedContainsWWWAuthenticate
289-- | A predicate that depends only on the response.
372-- | A predicate that depends only on the response.
290--
373--
291-- /Since 0.0.0.0/
374-- /Since 0.0.0.0/
292−data ResponsePredicate n r = ResponsePredicate
375+newtype ResponsePredicate = ResponsePredicate
293− { respPredName :: n
294− , respPred :: Response LBS.ByteString -> r
376+ { getResponsePredicate :: Response LBS.ByteString -> IO ()
295− } deriving (Functor, Generic)
377+ } deriving (Generic)
296−
378+
297−instance Bifunctor ResponsePredicate where
379+instance Semigroup ResponsePredicate where
298− first f (ResponsePredicate a b) = ResponsePredicate (f a) b
380+ ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
299− second = fmap
381+
300−
301−instance (Monoid n, Monoid r) => Monoid (ResponsePredicate n r) where
382+instance Monoid ResponsePredicate where
302− mempty = ResponsePredicate mempty mempty
383+ mempty = ResponsePredicate $ const $ return ()
303− a `mappend` b = ResponsePredicate
384+ mappend = (<>)
304− { respPredName = respPredName a <> respPredName b
305− , respPred = respPred a <> respPred b
306− }
307
385
308-- | A predicate that depends on both the request and the response.
386-- | A predicate that depends on both the request and the response.
309--
387--
310-- /Since 0.0.0.0/
388-- /Since 0.0.0.0/
311−data RequestPredicate n r = RequestPredicate
389+newtype RequestPredicate = RequestPredicate
312− { reqPredName :: n
313− , reqResps :: Request -> Manager -> IO (r, [Response LBS.ByteString])
390+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
314− } deriving (Generic, Functor)
391+ } deriving (Generic)
315
392
393+-- TODO: This isn't actually a monoid
316−instance Bifunctor RequestPredicate where
394+instance Monoid RequestPredicate where
317− first f (RequestPredicate a b) = RequestPredicate (f a) b
395+ mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
318− second = fmap
396+ mappend = (<>)
319
397
320-- TODO: This isn't actually a monoid
398-- TODO: This isn't actually a monoid
321−instance (Monoid n, Monoid r) => Monoid (RequestPredicate n r) where
399+instance Semigroup RequestPredicate where
322− mempty = RequestPredicate mempty (\r m -> httpLbs r m >>= \x -> return (mempty, [x]))
323− a `mappend` b = RequestPredicate
400+ RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
324− { reqPredName = reqPredName a <> reqPredName b
401+ liftM2 (<>) (a r mgr) (b r mgr)
325− , reqResps = \x m -> liftM2 (<>) (reqResps a x m) (reqResps b x m)
326− }
327
402
328-- | A set of predicates. Construct one with 'mempty' and '<%>'.
403-- | A set of predicates. Construct one with 'mempty' and '<%>'.
329−data Predicates n r = Predicates
404+data Predicates = Predicates
330− { reqPreds :: RequestPredicate n r
405+ { requestPredicates :: RequestPredicate
331− , respPreds :: ResponsePredicate n r
406+ , responsePredicates :: ResponsePredicate
332− } deriving (Generic, Functor)
407+ } deriving (Generic)
333−
334−instance (Monoid n, Monoid r) => Monoid (Predicates n r) where
335− mempty = Predicates mempty mempty
336− a `mappend` b = Predicates (reqPreds a <> reqPreds b) (respPreds a <> respPreds b)
337
408
409+instance Semigroup Predicates where
410+ a <> b = Predicates (requestPredicates a <> requestPredicates b)
411+ (responsePredicates a <> responsePredicates b)
338
412
413+instance Monoid Predicates where
414+ mempty = Predicates mempty mempty
415+ mappend = (<>)
339
416
340class JoinPreds a where
417class JoinPreds a where
341− joinPreds :: a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
418+ joinPreds :: a -> Predicates -> Predicates
342−
343−instance JoinPreds (RequestPredicate Text Bool) where
344− joinPreds p (Predicates x y) = Predicates (go <> x) y
345− where go = let p' = first return p
346− in fmap (\z -> if z then [] else reqPredName p') p'
347
419
348−instance JoinPreds (ResponsePredicate Text Bool) where
420+instance JoinPreds (RequestPredicate ) where
349− joinPreds p (Predicates x y) = Predicates x (go <> y)
421+ joinPreds p (Predicates x y) = Predicates (p <> x) y
350− where go = let p' = first return p
351− in fmap (\z -> if z then [] else respPredName p') p'
352
422
423+instance JoinPreds (ResponsePredicate ) where
424+ joinPreds p (Predicates x y) = Predicates x (p <> y)
353
425
354-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
426-- | Adds a new predicate (either `ResponsePredicate` or `RequestPredicate`) to
355-- the existing predicates.
427-- the existing predicates.
@@ -357,14 +429,17 @@ instance JoinPreds (ResponsePredicate Text Bool) where
357-- > not500 <%> onlyJsonObjects <%> empty
429-- > not500 <%> onlyJsonObjects <%> empty
358--
430--
359-- /Since 0.0.0.0/
431-- /Since 0.0.0.0/
360−(<%>) :: JoinPreds a => a -> Predicates [Text] [Text] -> Predicates [Text] [Text]
432+(<%>) :: JoinPreds a => a -> Predicates -> Predicates
361(<%>) = joinPreds
433(<%>) = joinPreds
362infixr 6 <%>
434infixr 6 <%>
363
435
364−finishPredicates :: Predicates [Text] [Text] -> Request -> Manager -> IO [Text]
436+finishPredicates :: Predicates -> Request -> Manager -> IO (Maybe PredicateFailure)
365−finishPredicates p req mgr = do
437+finishPredicates p req mgr = go `catch` \(e :: PredicateFailure) -> return $ Just e
366− (soFar, resps) <- reqResps (reqPreds p) req mgr
438+ where
367− return $ soFar <> mconcat [respPred (respPreds p) r | r <- resps]
439+ go = do
440+ resps <- getRequestPredicate (requestPredicates p) req mgr
441+ mapM_ (getResponsePredicate $ responsePredicates p) resps
442+ return Nothing
368
443
369-- * helpers
444-- * helpers
370
445
@@ -373,5 +448,14 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
373 Nothing -> False
448 Nothing -> False
374 Just v -> p v
449 Just v -> p v
375
450
451+isRFC822Date :: SBS.ByteString -> Bool
452+isRFC822Date s
453+ = case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of
454+ Nothing -> False
455+ Just (_ :: UTCTime) -> True
456+
376−status2XX :: Response b -> Bool
457+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
458+status2XX mreq resp t
377−status2XX r = status200 <= responseStatus r && responseStatus r < status300
459+ | status200 <= responseStatus resp && responseStatus resp < status300
460+ = return ()
461+ | otherwise = throw $ PredicateFailure t mreq resp
src/Servant/QuickCheck/Internal/QuickCheck.hs+95−27
@@ -1,26 +1,31 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE CPP #-}
1module Servant.QuickCheck.Internal.QuickCheck where
3module Servant.QuickCheck.Internal.QuickCheck where
2
4
5+import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
6+import Control.Monad (unless)
3import qualified Data.ByteString.Lazy as LBS
7import qualified Data.ByteString.Lazy as LBS
4import Data.Proxy (Proxy)
8import Data.Proxy (Proxy)
5−import Data.String (IsString (..))
6−import Data.Text (Text)
7−import GHC.Generics (Generic)
8import qualified Network.HTTP.Client as C
9import qualified Network.HTTP.Client as C
9import Network.Wai.Handler.Warp (withApplication)
10import Network.Wai.Handler.Warp (withApplication)
10import Prelude.Compat
11import Prelude.Compat
11import Servant (Context (EmptyContext), HasServer,
12import Servant (Context (EmptyContext), HasServer,
12 Server, serveWithContext)
13 Server, serveWithContext)
14+#if MIN_VERSION_servant_server(0,18,0)
15+import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, type (.++))
16+#endif
13import Servant.Client (BaseUrl (..), Scheme (..))
17import Servant.Client (BaseUrl (..), Scheme (..))
14import System.IO.Unsafe (unsafePerformIO)
18import System.IO.Unsafe (unsafePerformIO)
15import Test.Hspec (Expectation, expectationFailure)
19import Test.Hspec (Expectation, expectationFailure)
16−import Test.QuickCheck (Args (..), Result (..),
20+import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)
17− quickCheckWithResult)
18−import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run)
21+import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
22+ run)
23+import Test.QuickCheck.Property (counterexample)
19
24
20import Servant.QuickCheck.Internal.Equality
25import Servant.QuickCheck.Internal.Equality
26+import Servant.QuickCheck.Internal.ErrorTypes
21import Servant.QuickCheck.Internal.HasGenRequest
27import Servant.QuickCheck.Internal.HasGenRequest
22import Servant.QuickCheck.Internal.Predicates
28import Servant.QuickCheck.Internal.Predicates
23−import Servant.QuickCheck.Internal.ErrorTypes
24
29
25
30
26-- | Start a servant application on an open port, run the provided function,
31-- | Start a servant application on an open port, run the provided function,
@@ -35,7 +40,11 @@ withServantServer api = withServantServerAndContext api EmptyContext
35-- application.
40-- application.
36--
41--
37-- /Since 0.0.0.0/
42-- /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
38withServantServerAndContext :: HasServer a ctx
46withServantServerAndContext :: HasServer a ctx
47+#endif
39 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
48 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
40withServantServerAndContext api ctx server t
49withServantServerAndContext api ctx server t
41 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
50 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
@@ -53,21 +62,47 @@ withServantServerAndContext api ctx server t
53-- Evidently, if the behaviour of the server is expected to be
62-- Evidently, if the behaviour of the server is expected to be
54-- non-deterministic, this function may produce spurious failures
63-- non-deterministic, this function may produce spurious failures
55--
64--
65+-- Note that only valid requests are generated and tested. As an example of why
66+-- this matters, let's say your API specifies that a particular endpoint can
67+-- only generate @JSON@. @serversEqual@ will then not generate any requests
68+-- with an @Accept@ header _other_ than @application/json@. It may therefore
69+-- fail to notice that one application, when the request has @Accept:
70+-- text/html@, returns a @406 Not Acceptable@ HTTP response, and another
71+-- returns a @200 Success@, but with @application/json@ as the content-type.
72+--
73+-- The fact that only valid requests are tested also means that no endpoints
74+-- not listed in the API type are tested.
75+--
56-- /Since 0.0.0.0/
76-- /Since 0.0.0.0/
57serversEqual :: HasGenRequest a =>
77serversEqual :: HasGenRequest a =>
58 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
78 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
59serversEqual api burl1 burl2 args req = do
79serversEqual api burl1 burl2 args req = do
60− let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
80+ let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
81+ -- 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.
83+ deetsMVar <- newEmptyMVar
61− r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
84+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
62 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
85 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
63 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
86 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
64− assert $ getResponseEquality req resp1 resp2
87+ unless (getResponseEquality req resp1 resp2) $ do
88+ monitor (counterexample "hi" )
89+ _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
90+ assert False
65 case r of
91 case r of
66 Success {} -> return ()
92 Success {} -> return ()
93+ Failure{..} -> do
94+ mx <- tryReadMVar deetsMVar
95+ case mx of
96+ Just x ->
97+ expectationFailure $ "Failed:\n" ++ show x
98+ Nothing ->
99+ expectationFailure $ "We failed to record a reason for failure: " <> show r
67 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
100 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
68− Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
69− NoExpectedFailure {} -> expectationFailure $ "No expected failure"
101+ NoExpectedFailure {} -> expectationFailure "No expected failure"
102+#if MIN_VERSION_QuickCheck(2,12,0)
103+#else
70− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
104+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
105+#endif
71
106
72-- | Check that a server satisfies the set of properties specified.
107-- | Check that a server satisfies the set of properties specified.
73--
108--
@@ -89,36 +124,69 @@ serversEqual api burl1 burl2 args req = do
89--
124--
90-- /Since 0.0.0.0/
125-- /Since 0.0.0.0/
91serverSatisfies :: (HasGenRequest a) =>
126serverSatisfies :: (HasGenRequest a) =>
92− Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
127+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
128+serverSatisfies api = serverSatisfiesMgr api defManager
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
93−serverSatisfies api burl args preds = do
138+serverSatisfiesMgr api manager burl args preds = do
94− let reqs = ($ burl) <$> genRequest api
139+ let reqs = ($ burl) <$> runGenRequest api
140+ deetsMVar <- newEmptyMVar
95− r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
141+ r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
96− v <- run $ finishPredicates preds (noCheckStatus req) defManager
142+ v <- run $ finishPredicates preds (noCheckStatus req) manager
143+ _ <- run $ tryPutMVar deetsMVar v
144+ case v of
97− assert $ null v
145+ Just _ -> assert False
146+ _ -> return ()
98 case r of
147 case r of
99 Success {} -> return ()
148 Success {} -> return ()
149+ Failure {..} -> do
150+ mx <- tryReadMVar deetsMVar
151+ case mx of
152+ Just x ->
153+ expectationFailure $ "Failed:\n" ++ show x
154+ Nothing ->
155+ expectationFailure $ "We failed to record a reason for failure: " <> show r
100 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
156 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
101− Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
102 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
157 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
158+#if MIN_VERSION_QuickCheck(2,12,0)
159+#else
103− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
160+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
104−
161+#endif
105
162
106serverDoesntSatisfy :: (HasGenRequest a) =>
163serverDoesntSatisfy :: (HasGenRequest a) =>
107− Proxy a -> BaseUrl -> Args -> Predicates [Text] [Text] -> Expectation
164+ Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
108−serverDoesntSatisfy api burl args preds = do
165+serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
166+
167+serverDoesntSatisfyMgr :: (HasGenRequest a) =>
168+ Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
169+serverDoesntSatisfyMgr api manager burl args preds = do
109− let reqs = ($ burl) <$> genRequest api
170+ let reqs = ($ burl) <$> runGenRequest api
110 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
171 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
111− v <- run $ finishPredicates preds (noCheckStatus req) defManager
172+ v <- run $ finishPredicates preds (noCheckStatus req) manager
112 assert $ not $ null v
173 assert $ not $ null v
113 case r of
174 case r of
114 Success {} -> return ()
175 Success {} -> return ()
115 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
176 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
116 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
177 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
117 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
178 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
179+#if MIN_VERSION_QuickCheck(2,12,0)
180+#else
118− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
181+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
182+#endif
119
183
120noCheckStatus :: C.Request -> C.Request
184noCheckStatus :: C.Request -> C.Request
185+#if MIN_VERSION_http_client(0,5,0)
186+noCheckStatus = id
187+#else
121noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
188noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
189+#endif
122
190
123defManager :: C.Manager
191defManager :: C.Manager
124defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
192defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
stack.yaml+5−31
@@ -1,36 +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-04-20
1+resolver: nightly-2018-09-03
3−
4−# Local packages, usually specified by relative directory name
5packages:
2packages:
6- '.'
3- '.'
7−
8−# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
9extra-deps:
4extra-deps:
10−- servant-0.7
5+- hspec-discover-2.5.6
11−- servant-client-0.7
6+- hspec-core-2.5.6
12−- servant-server-0.7
7+- hspec-2.5.6
13−
8+- QuickCheck-2.12
14−# Override default flag values for local packages and extra-deps
15flags: {}
9flags: {}
16−
17−# Extra package databases containing global packages
18extra-package-dbs: []
10extra-package-dbs: []
19−
20−# Control whether we use the GHC we find on the path
21−# system-ghc: true
22−
23−# Require a specific version of stack, using version ranges
24−# require-stack-version: -any # Default
25−# require-stack-version: >= 1.0.0
26−
27−# Override the architecture used by stack, especially useful on Windows
28−# arch: i386
29−# arch: x86_64
30−
31−# Extra directories used by stack for building
32−# extra-include-dirs: [/path/to/dir]
33−# extra-lib-dirs: [/path/to/dir]
34−
35−# Allow a newer minor version of GHC than the snapshot specifies
36−# compiler-check: newer-minor
test/Doctest.hsdeleted−44
@@ -1,44 +0,0 @@
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+274−33
@@ -1,28 +1,46 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2module Servant.QuickCheck.InternalSpec (spec) where
2module Servant.QuickCheck.InternalSpec (spec) where
3
3
4+
4−import Control.Concurrent.MVar (newMVar, readMVar,
5+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
5− swapMVar)
6+import Control.Exception (SomeException)
7+import Control.Monad (replicateM)
6−import Control.Monad.IO.Class (liftIO)
8+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)
7import Prelude.Compat
13import Prelude.Compat
8import Servant
14import Servant
9−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
15+import Servant.HTML.Blaze (HTML)
16+import qualified Text.Blaze.Html as Blaze
17+import qualified Text.Blaze.Html5 as Blaze5
10−import Test.Hspec (Spec, context,
18+import Test.Hspec (Spec, context, describe, it, shouldBe,
11− describe, it,
19+ shouldContain)
12− pending, shouldBe)
13−import Test.Hspec.Core.Spec (Arg, Example,
20+import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
14− Result (..),
15− defaultParams,
21+ defaultParams, safeEvaluateExample)
16− evaluateExample)
22+import Test.QuickCheck.Gen (generate, unGen)
17−
23+import Test.QuickCheck.Random (mkQCGen)
24+
25+
26+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
27+
18−import Servant.QuickCheck
28+import Servant.QuickCheck
19−import Servant.QuickCheck.Internal (genRequest, Failure(..), serverDoesntSatisfy)
29+import Servant.QuickCheck.Internal (genRequest, runGenRequest,
30+ serverDoesntSatisfy)
20
31
21spec :: Spec
32spec :: Spec
22spec = do
33spec = do
23 serversEqualSpec
34 serversEqualSpec
24 serverSatisfiesSpec
35 serverSatisfiesSpec
25 isComprehensiveSpec
36 isComprehensiveSpec
37+ onlyJsonObjectSpec
38+ notLongerThanSpec
39+ queryParamsSpec
40+ queryFlagsSpec
41+ deepPathSpec
42+ htmlDocTypesSpec
43+ unbiasedGenerationSpec
26
44
27serversEqualSpec :: Spec
45serversEqualSpec :: Spec
28serversEqualSpec = describe "serversEqual" $ do
46serversEqualSpec = describe "serversEqual" $ do
@@ -33,21 +51,41 @@ serversEqualSpec = describe "serversEqual" $ do
33 serversEqual api burl1 burl2 args bodyEquality
51 serversEqual api burl1 burl2 args bodyEquality
34
52
35 context "when servers are not equal" $ do
53 context "when servers are not equal" $ do
36−
37− it "provides the failing requests in the error message" $ do
38− Fail _ err <- withServantServer api2 server2 $ \burl1 ->
39− withServantServer api2 server3 $ \burl2 -> do
40− evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
41− let ServerEqualityFailure req _ _ = read err
42− req `shouldBe` "failplz"
43−
44 it "provides the failing responses in the error message" $ do
54 it "provides the failing responses in the error message" $ do
45− Fail _ err <- withServantServer api2 server2 $ \burl1 ->
55+ FailedWith err <- withServantServer api2 server2 $ \burl1 ->
46 withServantServer api2 server3 $ \burl2 -> do
56 withServantServer api2 server3 $ \burl2 -> do
47 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
57 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
48− let ServerEqualityFailure _ r1 r2 = read err
58+ show err `shouldContain` "Server equality failed"
49− r1 `shouldBe` "1"
59+ show err `shouldContain` "Body: 1"
50− r2 `shouldBe` "2"
60+ show err `shouldContain` "Body: 2"
61+ 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"
51
89
52
90
53serverSatisfiesSpec :: Spec
91serverSatisfiesSpec :: Spec
@@ -67,16 +105,126 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
67 <%> notAllowedContainsAllowHeader
105 <%> notAllowedContainsAllowHeader
68 <%> mempty)
106 <%> mempty)
69
107
70− context "when predicates are false" $
108+ context "when predicates are false" $ do
109+
71− it "fails with informative error messages" $ pending
110+ it "fails with informative error messages" $ do
111+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
112+ evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
113+ show err `shouldContain` "notAllowedContainsAllowHeader"
114+ show err `shouldContain` "Headers"
115+ show err `shouldContain` "Body"
116+
117+
118+onlyJsonObjectSpec :: Spec
119+onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
120+
121+ it "fails correctly" $ do
122+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
123+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
124+ (onlyJsonObjects <%> mempty)
125+ show 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+
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)
72
147
73isComprehensiveSpec :: Spec
148isComprehensiveSpec :: Spec
74isComprehensiveSpec = describe "HasGenRequest" $ do
149isComprehensiveSpec = describe "HasGenRequest" $ do
75
150
76 it "has instances for all 'servant' combinators" $ do
151 it "has instances for all 'servant' combinators" $ do
77− let _g = genRequest comprehensiveAPI
152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
78 True `shouldBe` True -- This is a type-level check
153 True `shouldBe` True -- This is a type-level check
79
154
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
80
228
81------------------------------------------------------------------------------
229------------------------------------------------------------------------------
82-- APIs
230-- APIs
@@ -89,6 +237,17 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String
89api :: Proxy API
237api :: Proxy API
90api = Proxy
238api = Proxy
91
239
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+
92server :: IO (Server API)
251server :: IO (Server API)
93server = do
252server = do
94 mvar <- newMVar ""
253 mvar <- newMVar ""
@@ -102,23 +261,105 @@ type API2 = "failplz" :> Get '[JSON] Int
102api2 :: Proxy API2
261api2 :: Proxy API2
103api2 = Proxy
262api2 = Proxy
104
263
264+type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
265+
266+deepAPI :: Proxy DeepAPI
267+deepAPI = Proxy
268+
269+
105server2 :: IO (Server API2)
270server2 :: IO (Server API2)
106server2 = return $ return 1
271server2 = return $ return 1
107
272
108server3 :: IO (Server API2)
273server3 :: IO (Server API2)
109server3 = return $ return 2
274server3 = return $ return 2
110
275
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+
111ctx :: Context '[BasicAuthCheck ()]
341ctx :: Context '[BasicAuthCheck ()]
112ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
342ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
113------------------------------------------------------------------------------
343------------------------------------------------------------------------------
114-- Utils
344-- Utils
115------------------------------------------------------------------------------
345------------------------------------------------------------------------------
116−
117−evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
346+evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
347+evalExample e = do
118−evalExample e = evaluateExample e defaultParams ($ ()) progCallback
348+ r <- safeEvaluateExample 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"
119 where
353 where
120 progCallback _ = return ()
354 progCallback _ = return ()
121
355
356+data EvalResult
357+ = AnException SomeException
358+ | AllGood
359+ | FailedWith String
360+ deriving (Show)
361+
362+
122args :: Args
363args :: Args
123args = defaultArgs { maxSuccess = noOfTestCases }
364args = defaultArgs { maxSuccess = noOfTestCases }
124
365
@@ -126,5 +367,5 @@ noOfTestCases :: Int
126#if LONG_TESTS
367#if LONG_TESTS
127noOfTestCases = 20000
368noOfTestCases = 20000
128#else
369#else
129−noOfTestCases = 500
370+noOfTestCases = 1000
130#endif
371#endif