git.iko.soy/servant-quickcheck
on master help sign in
swap
053541388 ahead, 0 behind
.travis.yml+153−21
since splitsnapshots
unifiedsplit
@@ -1,26 +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−matrix:
16+dist: xenial
17+git:
18+ # whether to recursively clone submodules
19+ submodules: false
20+branches:
21+ only:
22+ - master
23+cache:
24+ directories:
25+ - $HOME/.cabal/packages
26+ - $HOME/.cabal/store
27+ - $HOME/.hlint
28+before_cache:
29+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
30+ # remove files that are regenerated by 'cabal update'
31+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
32+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
33+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
34+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
35+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
36+ - rm -rfv $CABALHOME/packages/head.hackage
37+jobs:
6 include:
38 include:
7− - env: CABALVER=1.22 GHCVER=7.10.1
39+ - compiler: ghc-8.8.3
8− addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1],sources: [hvr-ghc]}}
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"]}}
9− - env: CABALVER=1.24 GHCVER=8.0.1
41+ os: linux
10− addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
42+ - compiler: ghc-8.6.5
11−
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
12install:
88install:
13− - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
89+ - ${CABAL} --version
14− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
90+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
15− - ghc --version
91+ - |
16− - 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
17− - travis_retry cabal update
96+ - travis_retry ${CABAL} v2-update -v
18− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
97+ # Generate cabal.project
19−
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
20script:
114script:
21− - tinc && cabal configure --enable-tests && cabal build && cabal test
115+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
22− - cabal check
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
23
156
24−cache:
157+# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","servant-quickcheck.cabal"])
25− directories:
158+# EOF
26− - $HOME/.tinc/cache
CHANGELOG.yaml+166−18
@@ -1,26 +1,174 @@
1−upcoming:
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
2
7
3− changes:
8+ - description: "Relax constraints for GHC 8.10 (#70)"
9+ authors: felixmulder
10+ date: 2020-06-20
4
11
5− - description: Add notLongerThan predicate
12+ - version: "0.0.8.0"
6− pr: 17
13+ changes:
14+ - description: Support for servant-0.17
7− authors: jkarni
15+ authors: phadej
8− date: 2016-10-05
16+ date: 2019-01-23
9
17
10− - description: Add getsHaveLastModifiedHeader predicate
18+ - version: "0.0.7.3"
11− pr: none
19+ changes:
20+ - description: Support for servant-0.14
21+ issue: 53
12− authors: jkarni
22+ authors: phadej
13− date: 2016-10-03
23+ date: 2018-06-12
14
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+
15− - description: Raise upper bounds
164+ - description: Raise upper bounds
16− notes: >
165+ notes: >
17− For Quickcheck, aeson, http-client, servant, servant-client and
166+ For Quickcheck, aeson, http-client, servant, servant-client and
18− servant-server.
167+ servant-server.
19− pr: none
168+ pr: none
20− authors: jkarni
169+ authors: jkarni
21− date: 2016-10-03
170+ date: 2016-10-03
22
171
23−releases:
24
172
25 - version: "0.0.2.0"
173 - version: "0.0.2.0"
26 changes:
174 changes:
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+123−92
@@ -1,22 +1,22 @@
1−name: servant-quickcheck
1+name: servant-quickcheck
2−version: 0.0.2.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:
15+extra-source-files: CHANGELOG.yaml
16− CHANGELOG.yaml
16+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3
17
17
18source-repository head
18source-repository head
19− type: git
19+ type: git
20 location: https://github.com/haskell-servant/servant-quickcheck
20 location: https://github.com/haskell-servant/servant-quickcheck
21
21
22flag long-tests
22flag long-tests
@@ -24,84 +24,115 @@ flag long-tests
24 default: False
24 default: False
25
25
26library
26library
27− exposed-modules: Servant.QuickCheck
27+ exposed-modules:
28− , Servant.QuickCheck.Internal
28+ Servant.QuickCheck
29− , Servant.QuickCheck.Internal.Predicates
29+ Servant.QuickCheck.Internal
30− , Servant.QuickCheck.Internal.HasGenRequest
31− , Servant.QuickCheck.Internal.QuickCheck
32− , Servant.QuickCheck.Internal.Equality
30+ Servant.QuickCheck.Internal.Equality
33− , Servant.QuickCheck.Internal.ErrorTypes
31+ Servant.QuickCheck.Internal.ErrorTypes
34− build-depends: base >=4.8 && <4.10
32+ Servant.QuickCheck.Internal.HasGenRequest
35− , base-compat == 0.9.*
33+ Servant.QuickCheck.Internal.Predicates
36− , aeson > 0.8 && < 2
37− , bytestring == 0.10.*
38− , case-insensitive == 1.2.*
39− , clock >= 0.7 && < 0.8
40− , data-default-class >= 0.0 && < 0.2
41− , hspec == 2.2.*
42− , http-client >= 0.4.30 && < 0.6
43− , http-media == 0.6.*
44− , http-types > 0.8 && < 0.10
45− , mtl > 2.1 && < 2.3
46− , pretty == 1.1.*
47− , process >= 1.2 && < 1.5
48− , QuickCheck > 2.7 && < 2.10
34+ Servant.QuickCheck.Internal.QuickCheck
49− , servant > 0.6 && < 0.10
50− , servant-client > 0.6 && < 0.10
51− , servant-server > 0.6 && < 0.10
52− , split == 0.2.*
53− , string-conversions > 0.3 && < 0.5
54− , temporary == 1.2.*
55− , text == 1.*
56− , time >= 1.5 && < 1.7
57− , warp >= 3.2.4 && < 3.3
58
35
36+ build-depends:
37+ aeson >=0.8 && <2
38+ , base >=4.9 && <4.15
39+ , base-compat-batteries >=0.10.1 && <0.12
40+ , bytestring >=0.10 && <0.11
41+ , case-insensitive >=1.2 && <1.3
42+ , clock >=0.7 && <0.9
43+ , data-default-class >=0.0 && <0.2
44+ , hspec >=2.5.6 && <2.8
45+ , http-client >=0.4.30 && <0.8
46+ , http-media >=0.6 && <0.9
47+ , http-types >=0.8 && <0.13
48+ , mtl >=2.1 && <2.3
49+ , pretty >=1.1 && <1.2
50+ , process >=1.2 && <1.7
51+ , QuickCheck >=2.7 && <2.15
52+ , servant >=0.17 && <0.19
53+ , servant-client >=0.17 && <0.19
54+ , servant-server >=0.17 && <0.19
55+ , split >=0.2 && <0.3
56+ , string-conversions >=0.3 && <0.5
57+ , temporary >=1.2 && <1.4
58+ , text >=1 && <2
59+ , time >=1.5 && <1.11
60+ , warp >=3.2.4 && <3.4
61+
62+ if !impl(ghc >=8.0)
63+ build-depends: semigroups >=0.18.3 && <0.20
64+
59− hs-source-dirs: src
65+ hs-source-dirs: src
60− default-extensions: TypeOperators
66+ default-extensions:
67+ NoImplicitPrelude
68+ ConstraintKinds
69+ DataKinds
70+ DeriveDataTypeable
71+ DeriveFunctor
72+ DeriveGeneric
73+ FlexibleContexts
61− , FlexibleInstances
74+ FlexibleInstances
62− , FlexibleContexts
75+ FunctionalDependencies
63− , DataKinds
64− , GADTs
76+ GADTs
77+ KindSignatures
65− , MultiParamTypeClasses
78+ MultiParamTypeClasses
66− , DeriveFunctor
79+ OverloadedStrings
67− , KindSignatures
68− , RankNTypes
80+ RankNTypes
69− , ConstraintKinds
70− , DeriveGeneric
71− , ScopedTypeVariables
81+ ScopedTypeVariables
72− , OverloadedStrings
82+ TypeOperators
73− , FunctionalDependencies
83+
74− , NoImplicitPrelude
75− , DeriveDataTypeable
76− default-language: Haskell2010
84+ default-language: Haskell2010
77
85
78test-suite spec
86test-suite spec
79− type: exitcode-stdio-1.0
87+ type: exitcode-stdio-1.0
80− ghc-options: -Wall -threaded
88+ ghc-options: -Wall -threaded
81− default-language: Haskell2010
89+ default-language: Haskell2010
82− hs-source-dirs: test
90+ hs-source-dirs: test
83− main-is: Spec.hs
91+ main-is: Spec.hs
84− other-modules: Servant.QuickCheck.InternalSpec
92+ other-modules: Servant.QuickCheck.InternalSpec
85− build-depends: base == 4.*
93+ build-tool-depends: hspec-discover:hspec-discover -any
94+ build-depends:
95+ aeson
96+ , base
86− , base-compat
97+ , base-compat-batteries
87− , servant-quickcheck
98+ , blaze-html
99+ , bytestring
88− , hspec
100+ , hspec
89− , hspec-core
101+ , hspec-core >=2.5.5 && <2.8
90− , http-client
102+ , http-client
91− , warp
103+ , QuickCheck
104+ , quickcheck-io
105+ , servant
106+ , servant-blaze
107+ , servant-client
108+ , servant-quickcheck
92− , servant-server
109+ , servant-server
93− , servant-client
94− , servant
95− , transformers
110+ , transformers
96− , QuickCheck
111+ , warp
97− , quickcheck-io
112+
98− default-extensions: TypeOperators
113+ default-extensions:
99− , FlexibleInstances
114+ NoImplicitPrelude
115+ DataKinds
100− , FlexibleContexts
116+ FlexibleContexts
117+ FlexibleInstances
101− , GADTs
118+ GADTs
102− , DataKinds
103− , NoImplicitPrelude
104− , OverloadedStrings
119+ OverloadedStrings
105− , ScopedTypeVariables
120+ ScopedTypeVariables
121+ TypeOperators
122+
106 if flag(long-tests)
123 if flag(long-tests)
107− 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+6
@@ -29,11 +29,16 @@ module Servant.QuickCheck
29 , not500
29 , not500
30 , notLongerThan
30 , notLongerThan
31 , onlyJsonObjects
31 , onlyJsonObjects
32+ , honoursAcceptHeader
32 , notAllowedContainsAllowHeader
33 , notAllowedContainsAllowHeader
33 , unauthorizedContainsWWWAuthenticate
34 , unauthorizedContainsWWWAuthenticate
35+ , getsHaveLastModifiedHeader
34 , getsHaveCacheControlHeader
36 , getsHaveCacheControlHeader
35 , headsHaveCacheControlHeader
37 , headsHaveCacheControlHeader
36 , createContainsValidLocation
38 , createContainsValidLocation
39+ -- * Html Predicates
40+ , htmlIncludesDoctype
41+
37 -- *** Predicate utilities and types
42 -- *** Predicate utilities and types
38 , (<%>)
43 , (<%>)
39 , Predicates
44 , Predicates
@@ -49,6 +54,7 @@ module Servant.QuickCheck
49 -- represents other means of checking equality
54 -- represents other means of checking equality
50 -- *** Useful @ResponseEquality@s
55 -- *** Useful @ResponseEquality@s
51 , bodyEquality
56 , bodyEquality
57+ , jsonEquality
52 , allEquality
58 , allEquality
53 -- ** Response equality type
59 -- ** Response equality type
54 , ResponseEquality(..)
60 , ResponseEquality(..)
src/Servant/QuickCheck/Internal/Equality.hs+35−2
@@ -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
3import Data.Function (on)
6import Data.Function (on)
4import Network.HTTP.Client (Response, responseBody)
7import Network.HTTP.Client (Response, responseBody)
8+import Data.Semigroup (Semigroup (..))
5import Prelude.Compat
9import 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+3−1
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1module Servant.QuickCheck.Internal.ErrorTypes where
2module Servant.QuickCheck.Internal.ErrorTypes where
2
3
3import Control.Exception (Exception (..))
4import Control.Exception (Exception (..))
@@ -8,9 +9,10 @@ import Data.Typeable (Typeable)
8import GHC.Generics (Generic)
9import GHC.Generics (Generic)
9import qualified Network.HTTP.Client as C
10import qualified Network.HTTP.Client as C
10import Network.HTTP.Types (Header, statusCode)
11import Network.HTTP.Types (Header, statusCode)
11−import Prelude.Compat
12import Text.PrettyPrint
12import Text.PrettyPrint
13
13
14+import Prelude.Compat hiding ((<>))
15+
14data PredicateFailure
16data PredicateFailure
15 = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
17 = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
16 deriving (Typeable, Generic)
18 deriving (Typeable, Generic)
src/Servant/QuickCheck/Internal/HasGenRequest.hs+90−46
@@ -2,7 +2,6 @@
2{-# LANGUAGE PolyKinds #-}
2{-# LANGUAGE PolyKinds #-}
3module Servant.QuickCheck.Internal.HasGenRequest where
3module Servant.QuickCheck.Internal.HasGenRequest where
4
4
5−import Data.Monoid ((<>))
6import Data.String (fromString)
5import Data.String (fromString)
7import Data.String.Conversions (cs)
6import Data.String.Conversions (cs)
8import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
7import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
@@ -14,101 +13,136 @@ import Prelude.Compat
14import Servant
13import Servant
15import Servant.API.ContentTypes (AllMimeRender (..))
14import Servant.API.ContentTypes (AllMimeRender (..))
16import Servant.Client (BaseUrl (..), Scheme (..))
15import Servant.Client (BaseUrl (..), Scheme (..))
17−import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)
16+import Test.QuickCheck (Arbitrary (..), Gen, elements, frequency)
18−#if MIN_VERSION_servant(0,8,0)
17+
19import qualified Data.ByteString as BS
18import qualified Data.ByteString as BS
20−#endif
19+import qualified Data.ByteString.Internal as BS (c2w)
20+
21+
22+-- -----------------------------------------------------------------------------
23+-- runGenRequest
21
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
22
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.
23class HasGenRequest a where
42class HasGenRequest a where
24− genRequest :: Proxy a -> Gen (BaseUrl -> Request)
43+ genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))
44+
25
45
26instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
46instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
27 genRequest _
47 genRequest _
48+ = (lf + rf, frequency [l, r])
49+ where
28− = oneof [ genRequest (Proxy :: Proxy a)
50+ l@(lf, _) = genRequest (Proxy :: Proxy a)
29− , genRequest (Proxy :: Proxy b)
51+ r@(rf, _) = genRequest (Proxy :: Proxy b)
30− ]
52+
31
53
32instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
54instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
33− genRequest _ = do
55+ genRequest _ = (oldf, do
34 old' <- old
56 old' <- old
35− 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 })
36 where
62 where
37− old = genRequest (Proxy :: Proxy b)
63+ (oldf, old) = genRequest (Proxy :: Proxy b)
38 new = cs $ symbolVal (Proxy :: Proxy path)
64 new = cs $ symbolVal (Proxy :: Proxy path)
39
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+
40instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
75instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
41− => HasGenRequest (Capture x c :> b) where
76+ => HasGenRequest (Capture' mods x c :> b) where
42− genRequest _ = do
77+ genRequest _ = (oldf, do
43 old' <- old
78 old' <- old
44 new' <- toUrlPiece <$> new
79 new' <- toUrlPiece <$> new
45− 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 })
46 where
81 where
47− old = genRequest (Proxy :: Proxy b)
82+ (oldf, old) = genRequest (Proxy :: Proxy b)
48 new = arbitrary :: Gen c
83 new = arbitrary :: Gen c
49
84
50−#if MIN_VERSION_servant(0,8,0)
51instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
85instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
52 => HasGenRequest (CaptureAll x c :> b) where
86 => HasGenRequest (CaptureAll x c :> b) where
53− genRequest _ = do
87+ genRequest _ = (oldf, do
54 old' <- old
88 old' <- old
55 new' <- fmap (cs . toUrlPiece) <$> new
89 new' <- fmap (cs . toUrlPiece) <$> new
56 let new'' = BS.intercalate "/" new'
90 let new'' = BS.intercalate "/" new'
57− return $ \burl -> let r = old' burl in r { path = new'' <> path r }
91+ return $ \burl -> let r = old' burl in r { path = new'' <> path r })
58 where
92 where
59− old = genRequest (Proxy :: Proxy b)
93+ (oldf, old) = genRequest (Proxy :: Proxy b)
60 new = arbitrary :: Gen [c]
94 new = arbitrary :: Gen [c]
61−#endif
62
95
63instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
96instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
64− => HasGenRequest (Header h c :> b) where
97+ => HasGenRequest (Header' mods h c :> b) where
65− genRequest _ = do
98+ genRequest _ = (oldf, do
66 old' <- old
99 old' <- old
67− new' <- toUrlPiece <$> new
100+ new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
68 return $ \burl -> let r = old' burl in r {
101 return $ \burl -> let r = old' burl in r {
69− requestHeaders = (hdr, cs new') : requestHeaders r }
102+ requestHeaders = (hdr, cs new') : requestHeaders r })
70 where
103 where
71− old = genRequest (Proxy :: Proxy b)
104+ (oldf, old) = genRequest (Proxy :: Proxy b)
72 hdr = fromString $ symbolVal (Proxy :: Proxy h)
105 hdr = fromString $ symbolVal (Proxy :: Proxy h)
73 new = arbitrary :: Gen c
106 new = arbitrary :: Gen c
74
107
75instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
108instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
76− => HasGenRequest (ReqBody x c :> b) where
109+ => HasGenRequest (ReqBody' mods x c :> b) where
77− genRequest _ = do
110+ genRequest _ = (oldf, do
78− old' <- old
111+ old' <- old -- TODO: generate lenient
79 new' <- new
112 new' <- new
80 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
113 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
81 return $ \burl -> let r = old' burl in r {
114 return $ \burl -> let r = old' burl in r {
82 requestBody = RequestBodyLBS bd
115 requestBody = RequestBodyLBS bd
83 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
116 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
84− }
117+ })
85 where
118 where
86− old = genRequest (Proxy :: Proxy b)
119+ (oldf, old) = genRequest (Proxy :: Proxy b)
87 new = arbitrary :: Gen c
120 new = arbitrary :: Gen c
88
121
89instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
122instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
90− => HasGenRequest (QueryParam x c :> b) where
123+ => HasGenRequest (QueryParam' mods x c :> b) where
91− genRequest _ = do
124+ genRequest _ = (oldf, do
92− new' <- new
125+ new' <- new -- TODO: generate lenient or/and optional
93 old' <- old
126 old' <- old
94− return $ \burl -> let r = old' burl in r {
127+ return $ \burl -> let r = old' burl
95− queryString = queryString r
96− <> 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 })
97 where
131 where
98− old = genRequest (Proxy :: Proxy b)
132+ (oldf, old) = genRequest (Proxy :: Proxy b)
99 param = cs $ symbolVal (Proxy :: Proxy x)
133 param = cs $ symbolVal (Proxy :: Proxy x)
100 new = arbitrary :: Gen c
134 new = arbitrary :: Gen c
101
135
102instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
136instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
103 => HasGenRequest (QueryParams x c :> b) where
137 => HasGenRequest (QueryParams x c :> b) where
104− genRequest _ = do
138+ genRequest _ = (oldf, do
105 new' <- new
139 new' <- new
106 old' <- old
140 old' <- old
107 return $ \burl -> let r = old' burl in r {
141 return $ \burl -> let r = old' burl in r {
108 queryString = queryString r
142 queryString = queryString r
109− <> if length new' > 0 then fold (toParam <$> new') else ""}
143+ <> if length new' > 0 then fold (toParam <$> new') else ""})
110 where
144 where
111− old = genRequest (Proxy :: Proxy b)
145+ (oldf, old) = genRequest (Proxy :: Proxy b)
112 param = cs $ symbolVal (Proxy :: Proxy x)
146 param = cs $ symbolVal (Proxy :: Proxy x)
113 new = arbitrary :: Gen [c]
147 new = arbitrary :: Gen [c]
114 toParam c = param <> "[]=" <> cs (toQueryParam c)
148 toParam c = param <> "[]=" <> cs (toQueryParam c)
@@ -116,22 +150,32 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
116
150
117instance (KnownSymbol x, HasGenRequest b)
151instance (KnownSymbol x, HasGenRequest b)
118 => HasGenRequest (QueryFlag x :> b) where
152 => HasGenRequest (QueryFlag x :> b) where
119− genRequest _ = do
153+ genRequest _ = (oldf, do
120 old' <- old
154 old' <- old
121− return $ \burl -> let r = old' burl in r {
155+ return $ \burl -> let r = old' burl
156+ qs = queryString r in r {
122− queryString = queryString r <> param <> "=" }
157+ queryString = if BS.null qs then param else param <> "&" <> qs })
123 where
158 where
124− old = genRequest (Proxy :: Proxy b)
159+ (oldf, old) = genRequest (Proxy :: Proxy b)
125 param = cs $ symbolVal (Proxy :: Proxy x)
160 param = cs $ symbolVal (Proxy :: Proxy x)
126
161
127instance (ReflectMethod method)
162instance (ReflectMethod method)
128 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
163 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
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
129− genRequest _ = return $ \burl -> defaultRequest
173+ genRequest _ = (1, return $ \burl -> defaultRequest
130 { host = cs $ baseUrlHost burl
174 { host = cs $ baseUrlHost burl
131 , port = baseUrlPort burl
175 , port = baseUrlPort burl
132 , secure = baseUrlScheme burl == Https
176 , secure = baseUrlScheme burl == Https
133 , method = reflectMethod (Proxy :: Proxy method)
177 , method = reflectMethod (Proxy :: Proxy method)
134− }
178+ })
135
179
136instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
180instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
137 genRequest _ = genRequest (Proxy :: Proxy a)
181 genRequest _ = genRequest (Proxy :: Proxy a)
src/Servant/QuickCheck/Internal/Predicates.hs+79−35
@@ -1,29 +1,33 @@
1module Servant.QuickCheck.Internal.Predicates where
1module Servant.QuickCheck.Internal.Predicates where
2
2
3import Control.Exception (catch, throw)
3import Control.Exception (catch, throw)
4−import Control.Monad (when, unless, liftM2)
4+import Control.Monad (liftM2, unless, when)
5import Data.Aeson (Object, decode)
5import Data.Aeson (Object, decode)
6+import Data.Bifunctor (first)
6import qualified Data.ByteString as SBS
7import qualified Data.ByteString as SBS
7import qualified Data.ByteString.Char8 as SBSC
8import qualified Data.ByteString.Char8 as SBSC
8import qualified Data.ByteString.Lazy as LBS
9import qualified Data.ByteString.Lazy as LBS
9−import Data.CaseInsensitive (mk)
10+import Data.CaseInsensitive (foldCase, foldedCase, mk)
10import Data.Either (isRight)
11import Data.Either (isRight)
11import Data.List.Split (wordsBy)
12import Data.List.Split (wordsBy)
12import Data.Maybe (fromMaybe, isJust)
13import Data.Maybe (fromMaybe, isJust)
13−import Data.Monoid ((<>))
14+import Data.Semigroup (Semigroup (..))
15+import qualified Data.Text as T
14−import Data.Time (parseTimeM, defaultTimeLocale,
16+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
15− rfc822DateFormat, UTCTime)
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, requestHeaders, responseBody,
20+ method, parseRequest, requestHeaders,
21+ responseBody, responseHeaders,
19− responseHeaders, parseRequest, responseStatus)
22+ responseStatus)
20import Network.HTTP.Media (matchAccept)
23import Network.HTTP.Media (matchAccept)
21import Network.HTTP.Types (methodGet, methodHead, parseMethod,
24import Network.HTTP.Types (methodGet, methodHead, parseMethod,
22 renderStdMethod, status100, status200,
25 renderStdMethod, status100, status200,
23 status201, status300, status401,
26 status201, status300, status401,
24 status405, status500)
27 status405, status500)
25−import System.Clock (toNanoSecs, Clock(Monotonic), getTime, diffTimeSpec)
26import Prelude.Compat
28import Prelude.Compat
29+import System.Clock (Clock (Monotonic), diffTimeSpec,
30+ getTime, toNanoSecs)
27
31
28import Servant.QuickCheck.Internal.ErrorTypes
32import Servant.QuickCheck.Internal.ErrorTypes
29
33
@@ -39,14 +43,14 @@ import Servant.QuickCheck.Internal.ErrorTypes
39-- /Since 0.0.0.0/
43-- /Since 0.0.0.0/
40not500 :: ResponsePredicate
44not500 :: ResponsePredicate
41not500 = ResponsePredicate $ \resp ->
45not500 = ResponsePredicate $ \resp ->
42− when (responseStatus resp == status500) $ fail "not500"
46+ when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
43
47
44-- | [__Optional__]
48-- | [__Optional__]
45--
49--
46-- This function checks that the response from the server does not take longer
50-- This function checks that the response from the server does not take longer
47-- than the specified number of nanoseconds.
51-- than the specified number of nanoseconds.
48--
52--
49−-- #SINCE#
53+-- /Since 0.0.2.1/
50notLongerThan :: Integer -> RequestPredicate
54notLongerThan :: Integer -> RequestPredicate
51notLongerThan maxAllowed
55notLongerThan maxAllowed
52 = RequestPredicate $ \req mgr -> do
56 = RequestPredicate $ \req mgr -> do
@@ -80,9 +84,13 @@ notLongerThan maxAllowed
80-- /Since 0.0.0.0/
84-- /Since 0.0.0.0/
81onlyJsonObjects :: ResponsePredicate
85onlyJsonObjects :: ResponsePredicate
82onlyJsonObjects
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
83− = ResponsePredicate (\resp -> case decode (responseBody resp) of
91+ case (decode (responseBody resp) :: Maybe Object) of
84− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
92+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
85− Just (_ :: Object) -> return ())
93+ Just _ -> return ())
86
94
87-- | __Optional__
95-- | __Optional__
88--
96--
@@ -110,12 +118,12 @@ createContainsValidLocation
110 resp <- httpLbs req mgr
118 resp <- httpLbs req mgr
111 if responseStatus resp == status201
119 if responseStatus resp == status201
112 then case lookup "Location" $ responseHeaders resp of
120 then case lookup "Location" $ responseHeaders resp of
113− Nothing -> fail n
121+ Nothing -> throw $ PredicateFailure n (Just req) resp
114 Just l -> case parseRequest $ SBSC.unpack l of
122 Just l -> case parseRequest $ SBSC.unpack l of
115− Nothing -> fail n
123+ Nothing -> throw $ PredicateFailure n (Just req) resp
116 Just x -> do
124 Just x -> do
117 resp2 <- httpLbs x mgr
125 resp2 <- httpLbs x mgr
118− status2XX resp2 n
126+ status2XX (Just req) resp2 n
119 return [resp, resp2]
127 return [resp, resp2]
120 else return [resp]
128 else return [resp]
121
129
@@ -143,7 +151,7 @@ createContainsValidLocation
143-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
151-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
144-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
152-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
145--
153--
146−-- #SINCE#
154+-- /Since 0.0.2.1/
147getsHaveLastModifiedHeader :: RequestPredicate
155getsHaveLastModifiedHeader :: RequestPredicate
148getsHaveLastModifiedHeader
156getsHaveLastModifiedHeader
149 = RequestPredicate $ \req mgr ->
157 = RequestPredicate $ \req mgr ->
@@ -167,23 +175,27 @@ getsHaveLastModifiedHeader
167-- This function checks that every @405 Method Not Allowed@ response contains
175-- This function checks that every @405 Method Not Allowed@ response contains
168-- an @Allow@ header with a list of standard HTTP methods.
176-- an @Allow@ header with a list of standard HTTP methods.
169--
177--
178+-- Note that 'servant' itself does not currently set the @Allow@ headers.
179+--
170-- __References__:
180-- __References__:
171--
181--
172-- * @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>
173-- * 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>
174--
185--
175-- /Since 0.0.0.0/
186-- /Since 0.0.0.0/
176notAllowedContainsAllowHeader :: RequestPredicate
187notAllowedContainsAllowHeader :: RequestPredicate
177notAllowedContainsAllowHeader
188notAllowedContainsAllowHeader
178 = RequestPredicate $ \req mgr -> do
189 = RequestPredicate $ \req mgr -> do
179− resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
190+ let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
180− | m <- [minBound .. maxBound ]
181− , renderStdMethod m /= method req ]
191+ , renderStdMethod m /= method req ]
192+ resp <- mapM (flip httpLbs mgr) reqs
193+
182− case filter pred' resp of
194+ case filter pred' (zip reqs resp) of
183− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
195+ (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
184 [] -> return resp
196 [] -> return resp
185 where
197 where
186− pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
198+ pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
187 where
199 where
188 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
189 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -213,7 +225,7 @@ honoursAcceptHeader
213 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
225 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
214 if status100 < scode && scode < status300
226 if status100 < scode && scode < status300
215 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
227 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
216− then fail "honoursAcceptHeader"
228+ then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
217 else return [resp]
229 else return [resp]
218 else return [resp]
230 else return [resp]
219
231
@@ -324,7 +336,29 @@ unauthorizedContainsWWWAuthenticate
324 = ResponsePredicate $ \resp ->
336 = ResponsePredicate $ \resp ->
325 if responseStatus resp == status401
337 if responseStatus resp == status401
326 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
327− fail "unauthorizedContainsWWWAuthenticate"
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
328 else return ()
362 else return ()
329
363
330-- * Predicate logic
364-- * Predicate logic
@@ -342,33 +376,43 @@ newtype ResponsePredicate = ResponsePredicate
342 { getResponsePredicate :: Response LBS.ByteString -> IO ()
376 { getResponsePredicate :: Response LBS.ByteString -> IO ()
343 } deriving (Generic)
377 } deriving (Generic)
344
378
379+instance Semigroup ResponsePredicate where
380+ ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
381+
345instance Monoid ResponsePredicate where
382instance Monoid ResponsePredicate where
346 mempty = ResponsePredicate $ const $ return ()
383 mempty = ResponsePredicate $ const $ return ()
347− ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
384+ mappend = (<>)
348
385
349-- | A predicate that depends on both the request and the response.
386-- | A predicate that depends on both the request and the response.
350--
387--
351-- /Since 0.0.0.0/
388-- /Since 0.0.0.0/
352newtype RequestPredicate = RequestPredicate
389newtype RequestPredicate = RequestPredicate
353− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
390+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
354 } deriving (Generic)
391 } deriving (Generic)
355
392
356-- TODO: This isn't actually a monoid
393-- TODO: This isn't actually a monoid
357instance Monoid RequestPredicate where
394instance Monoid RequestPredicate where
358 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
395 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
396+ mappend = (<>)
397+
398+-- TODO: This isn't actually a monoid
399+instance Semigroup RequestPredicate where
359− RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
400+ RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
360 liftM2 (<>) (a r mgr) (b r mgr)
401 liftM2 (<>) (a r mgr) (b r mgr)
361
402
362-- | A set of predicates. Construct one with 'mempty' and '<%>'.
403-- | A set of predicates. Construct one with 'mempty' and '<%>'.
363data Predicates = Predicates
404data Predicates = Predicates
364− { requestPredicates :: RequestPredicate
405+ { requestPredicates :: RequestPredicate
365 , responsePredicates :: ResponsePredicate
406 , responsePredicates :: ResponsePredicate
366 } deriving (Generic)
407 } deriving (Generic)
367
408
409+instance Semigroup Predicates where
410+ a <> b = Predicates (requestPredicates a <> requestPredicates b)
411+ (responsePredicates a <> responsePredicates b)
412+
368instance Monoid Predicates where
413instance Monoid Predicates where
369 mempty = Predicates mempty mempty
414 mempty = Predicates mempty mempty
370− a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
415+ mappend = (<>)
371− (responsePredicates a <> responsePredicates b)
372
416
373class JoinPreds a where
417class JoinPreds a where
374 joinPreds :: a -> Predicates -> Predicates
418 joinPreds :: a -> Predicates -> Predicates
@@ -410,8 +454,8 @@ isRFC822Date s
410 Nothing -> False
454 Nothing -> False
411 Just (_ :: UTCTime) -> True
455 Just (_ :: UTCTime) -> True
412
456
413−status2XX :: Monad m => Response b -> String -> m ()
457+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
414−status2XX r t
458+status2XX mreq resp t
415− | status200 <= responseStatus r && responseStatus r < status300
459+ | status200 <= responseStatus resp && responseStatus resp < status300
416 = return ()
460 = return ()
417− | otherwise = fail t
461+ | otherwise = throw $ PredicateFailure t mreq resp
src/Servant/QuickCheck/Internal/QuickCheck.hs+64−27
@@ -2,7 +2,7 @@
2{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3module Servant.QuickCheck.Internal.QuickCheck where
3module Servant.QuickCheck.Internal.QuickCheck where
4
4
5−import Control.Concurrent (modifyMVar_, newMVar, readMVar)
5+import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
6import Control.Monad (unless)
6import Control.Monad (unless)
7import qualified Data.ByteString.Lazy as LBS
7import qualified Data.ByteString.Lazy as LBS
8import Data.Proxy (Proxy)
8import Data.Proxy (Proxy)
@@ -11,11 +11,13 @@ import Network.Wai.Handler.Warp (withApplication)
11import Prelude.Compat
11import Prelude.Compat
12import Servant (Context (EmptyContext), HasServer,
12import Servant (Context (EmptyContext), HasServer,
13 Server, serveWithContext)
13 Server, serveWithContext)
14+#if MIN_VERSION_servant_server(0,18,0)
15+import Servant (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, type (.++))
16+#endif
14import Servant.Client (BaseUrl (..), Scheme (..))
17import Servant.Client (BaseUrl (..), Scheme (..))
15import System.IO.Unsafe (unsafePerformIO)
18import System.IO.Unsafe (unsafePerformIO)
16import Test.Hspec (Expectation, expectationFailure)
19import Test.Hspec (Expectation, expectationFailure)
17−import Test.QuickCheck (Args (..), Result (..),
20+import Test.QuickCheck (Args (..), Result (..), quickCheckWithResult)
18− quickCheckWithResult)
19import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
21import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,
20 run)
22 run)
21import Test.QuickCheck.Property (counterexample)
23import Test.QuickCheck.Property (counterexample)
@@ -38,7 +40,11 @@ withServantServer api = withServantServerAndContext api EmptyContext
38-- application.
40-- application.
39--
41--
40-- /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
41withServantServerAndContext :: HasServer a ctx
46withServantServerAndContext :: HasServer a ctx
47+#endif
42 => 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
43withServantServerAndContext api ctx server t
49withServantServerAndContext api ctx server t
44 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
50 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
@@ -71,25 +77,32 @@ withServantServerAndContext api ctx server t
71serversEqual :: HasGenRequest a =>
77serversEqual :: HasGenRequest a =>
72 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
78 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
73serversEqual api burl1 burl2 args req = do
79serversEqual api burl1 burl2 args req = do
74− let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
80+ let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
75 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
81 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
76 -- return results when a test fails, since an exception is throw.
82 -- return results when a test fails, since an exception is throw.
77− deetsMVar <- newMVar $ error "should not be called"
83+ deetsMVar <- newEmptyMVar
78 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
84 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
79 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
85 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
80 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
86 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
81 unless (getResponseEquality req resp1 resp2) $ do
87 unless (getResponseEquality req resp1 resp2) $ do
82 monitor (counterexample "hi" )
88 monitor (counterexample "hi" )
83− run $ modifyMVar_ deetsMVar $ const $ return $
84− ServerEqualityFailure req1 resp1 resp2
89+ _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
85 assert False
90 assert False
86 case r of
91 case r of
87 Success {} -> return ()
92 Success {} -> return ()
88− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
93+ Failure{..} -> do
94+ mx <- tryReadMVar deetsMVar
95+ case mx of
96+ Just x ->
89− "Failed:\n" ++ show x
97+ expectationFailure $ "Failed:\n" ++ show x
98+ Nothing ->
99+ expectationFailure $ "We failed to record a reason for failure: " <> show r
90 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
100 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
91− NoExpectedFailure {} -> expectationFailure $ "No expected failure"
101+ NoExpectedFailure {} -> expectationFailure "No expected failure"
102+#if MIN_VERSION_QuickCheck(2,12,0)
103+#else
92− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
104+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
105+#endif
93
106
94-- | Check that a server satisfies the set of properties specified.
107-- | Check that a server satisfies the set of properties specified.
95--
108--
@@ -112,37 +125,61 @@ serversEqual api burl1 burl2 args req = do
112-- /Since 0.0.0.0/
125-- /Since 0.0.0.0/
113serverSatisfies :: (HasGenRequest a) =>
126serverSatisfies :: (HasGenRequest a) =>
114 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
127 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
115−serverSatisfies api burl args preds = do
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
138+serverSatisfiesMgr api manager burl args preds = do
116− let reqs = ($ burl) <$> genRequest api
139+ let reqs = ($ burl) <$> runGenRequest api
117− deetsMVar <- newMVar $ error "should not be called"
140+ deetsMVar <- newEmptyMVar
118 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
141 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
119− v <- run $ finishPredicates preds (noCheckStatus req) defManager
142+ v <- run $ finishPredicates preds (noCheckStatus req) manager
120− run $ modifyMVar_ deetsMVar $ const $ return v
143+ _ <- run $ tryPutMVar deetsMVar v
121− case v of
144+ case v of
122− Just _ -> assert False
145+ Just _ -> assert False
123− _ -> return ()
146+ _ -> return ()
124 case r of
147 case r of
125 Success {} -> return ()
148 Success {} -> return ()
126− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
149+ Failure {..} -> do
150+ mx <- tryReadMVar deetsMVar
151+ case mx of
152+ Just x ->
127− "Failed:\n" ++ show x
153+ expectationFailure $ "Failed:\n" ++ show x
154+ Nothing ->
155+ expectationFailure $ "We failed to record a reason for failure: " <> show r
128 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
156 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
129 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
157 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
158+#if MIN_VERSION_QuickCheck(2,12,0)
159+#else
130− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
160+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
131−
161+#endif
132
162
133serverDoesntSatisfy :: (HasGenRequest a) =>
163serverDoesntSatisfy :: (HasGenRequest a) =>
134 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
164 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
135−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
136− let reqs = ($ burl) <$> genRequest api
170+ let reqs = ($ burl) <$> runGenRequest api
137 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
171 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
138− v <- run $ finishPredicates preds (noCheckStatus req) defManager
172+ v <- run $ finishPredicates preds (noCheckStatus req) manager
139 assert $ not $ null v
173 assert $ not $ null v
140 case r of
174 case r of
141 Success {} -> return ()
175 Success {} -> return ()
142 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
176 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
143 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
177 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
144 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
178 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
179+#if MIN_VERSION_QuickCheck(2,12,0)
180+#else
145− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
181+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
182+#endif
146
183
147noCheckStatus :: C.Request -> C.Request
184noCheckStatus :: C.Request -> C.Request
148#if MIN_VERSION_http_client(0,5,0)
185#if MIN_VERSION_http_client(0,5,0)
stack-ghc-8.0.1.yamldeleted−10
@@ -1,10 +0,0 @@
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-10-03
3−packages:
4−- '.'
5−extra-deps:
6−- 'servant-0.9'
7−- 'servant-server-0.9'
8−- 'servant-client-0.9'
9−flags: {}
10−extra-package-dbs: []
stack.yaml+6−3
@@ -1,7 +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)
1+resolver: nightly-2018-09-03
2−resolver: lts-6.17
3packages:
2packages:
4- '.'
3- '.'
5−extra-deps: []
4+extra-deps:
5+- hspec-discover-2.5.6
6+- hspec-core-2.5.6
7+- hspec-2.5.6
8+- QuickCheck-2.12
6flags: {}
9flags: {}
7extra-package-dbs: []
10extra-package-dbs: []
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+249−37
@@ -1,23 +1,33 @@
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, swapMVar)
5+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
6+import Control.Exception (SomeException)
7+import Control.Monad (replicateM)
5−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)
6−import Prelude.Compat
13+import Prelude.Compat
7−import Servant
14+import Servant
8−#if MIN_VERSION_servant(0,8,0)
15+import Servant.HTML.Blaze (HTML)
9−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
16+import qualified Text.Blaze.Html as Blaze
10−#else
17+import qualified Text.Blaze.Html5 as Blaze5
11−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI, ComprehensiveAPI)
12−#endif
13−import Test.Hspec (Spec, context, describe, it,
18+import Test.Hspec (Spec, context, describe, it, shouldBe,
14− shouldBe, shouldContain)
19+ shouldContain)
15−import Test.Hspec.Core.Spec (Arg, Example, Result (..),
20+import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
16− defaultParams,
21+ defaultParams, safeEvaluateExample)
17− evaluateExample)
22+import Test.QuickCheck.Gen (generate, unGen)
23+import Test.QuickCheck.Random (mkQCGen)
24+
25+
26+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
18
27
19import Servant.QuickCheck
28import Servant.QuickCheck
20−import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
29+import Servant.QuickCheck.Internal (genRequest, runGenRequest,
30+ serverDoesntSatisfy)
21
31
22spec :: Spec
32spec :: Spec
23spec = do
33spec = do
@@ -26,6 +36,11 @@ spec = do
26 isComprehensiveSpec
36 isComprehensiveSpec
27 onlyJsonObjectSpec
37 onlyJsonObjectSpec
28 notLongerThanSpec
38 notLongerThanSpec
39+ queryParamsSpec
40+ queryFlagsSpec
41+ deepPathSpec
42+ htmlDocTypesSpec
43+ unbiasedGenerationSpec
29
44
30serversEqualSpec :: Spec
45serversEqualSpec :: Spec
31serversEqualSpec = describe "serversEqual" $ do
46serversEqualSpec = describe "serversEqual" $ do
@@ -36,15 +51,42 @@ serversEqualSpec = describe "serversEqual" $ do
36 serversEqual api burl1 burl2 args bodyEquality
51 serversEqual api burl1 burl2 args bodyEquality
37
52
38 context "when servers are not equal" $ do
53 context "when servers are not equal" $ do
39−
40−
41 it "provides the failing responses in the error message" $ do
54 it "provides the failing responses in the error message" $ do
42− Fail _ err <- withServantServer api2 server2 $ \burl1 ->
55+ FailedWith err <- withServantServer api2 server2 $ \burl1 ->
43 withServantServer api2 server3 $ \burl2 -> do
56 withServantServer api2 server3 $ \burl2 -> do
44 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
57 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
58+ show err `shouldContain` "Server equality failed"
45 show err `shouldContain` "Body: 1"
59 show err `shouldContain` "Body: 1"
46 show err `shouldContain` "Body: 2"
60 show err `shouldContain` "Body: 2"
47− show err `shouldContain` "Path: failplz/"
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"
89+
48
90
49serverSatisfiesSpec :: Spec
91serverSatisfiesSpec :: Spec
50serverSatisfiesSpec = describe "serverSatisfies" $ do
92serverSatisfiesSpec = describe "serverSatisfies" $ do
@@ -66,29 +108,38 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
66 context "when predicates are false" $ do
108 context "when predicates are false" $ do
67
109
68 it "fails with informative error messages" $ do
110 it "fails with informative error messages" $ do
69− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
111+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
70− evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
112+ evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
71− err `shouldContain` "getsHaveCacheControlHeader"
113+ show err `shouldContain` "notAllowedContainsAllowHeader"
72− err `shouldContain` "Headers"
114+ show err `shouldContain` "Headers"
73− err `shouldContain` "Body"
115+ show err `shouldContain` "Body"
116+
74
117
75onlyJsonObjectSpec :: Spec
118onlyJsonObjectSpec :: Spec
76onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
119onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
77
120
78 it "fails correctly" $ do
121 it "fails correctly" $ do
79− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
122+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
80 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
123 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
81 (onlyJsonObjects <%> mempty)
124 (onlyJsonObjects <%> mempty)
82− err `shouldContain` "onlyJsonObjects"
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)
83
134
84notLongerThanSpec :: Spec
135notLongerThanSpec :: Spec
85notLongerThanSpec = describe "notLongerThan" $ do
136notLongerThanSpec = describe "notLongerThan" $ do
86
137
87 it "fails correctly" $ do
138 it "fails correctly" $ do
88− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
139+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
89 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
140 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
90 (notLongerThan 1 <%> mempty)
141 (notLongerThan 1 <%> mempty)
91− err `shouldContain` "notLongerThan"
142+ show err `shouldContain` "notLongerThan"
92
143
93 it "succeeds correctly" $ do
144 it "succeeds correctly" $ do
94 withServantServerAndContext api ctx server $ \burl ->
145 withServantServerAndContext api ctx server $ \burl ->
@@ -98,9 +149,82 @@ isComprehensiveSpec :: Spec
98isComprehensiveSpec = describe "HasGenRequest" $ do
149isComprehensiveSpec = describe "HasGenRequest" $ do
99
150
100 it "has instances for all 'servant' combinators" $ do
151 it "has instances for all 'servant' combinators" $ do
101− let _g = genRequest comprehensiveAPIWithoutRaw
152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
102 True `shouldBe` True -- This is a type-level check
153 True `shouldBe` True -- This is a type-level check
103
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
104
228
105------------------------------------------------------------------------------
229------------------------------------------------------------------------------
106-- APIs
230-- APIs
@@ -113,6 +237,17 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String
113api :: Proxy API
237api :: Proxy API
114api = Proxy
238api = Proxy
115
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+
116server :: IO (Server API)
251server :: IO (Server API)
117server = do
252server = do
118 mvar <- newMVar ""
253 mvar <- newMVar ""
@@ -126,23 +261,105 @@ type API2 = "failplz" :> Get '[JSON] Int
126api2 :: Proxy API2
261api2 :: Proxy API2
127api2 = Proxy
262api2 = Proxy
128
263
264+type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
265+
266+deepAPI :: Proxy DeepAPI
267+deepAPI = Proxy
268+
269+
129server2 :: IO (Server API2)
270server2 :: IO (Server API2)
130server2 = return $ return 1
271server2 = return $ return 1
131
272
132server3 :: IO (Server API2)
273server3 :: IO (Server API2)
133server3 = return $ return 2
274server3 = return $ return 2
134
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+
135ctx :: Context '[BasicAuthCheck ()]
341ctx :: Context '[BasicAuthCheck ()]
136ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
342ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
137------------------------------------------------------------------------------
343------------------------------------------------------------------------------
138-- Utils
344-- Utils
139------------------------------------------------------------------------------
345------------------------------------------------------------------------------
140−
141−evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
346+evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
347+evalExample e = do
142−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"
143 where
353 where
144 progCallback _ = return ()
354 progCallback _ = return ()
145
355
356+data EvalResult
357+ = AnException SomeException
358+ | AllGood
359+ | FailedWith String
360+ deriving (Show)
361+
362+
146args :: Args
363args :: Args
147args = defaultArgs { maxSuccess = noOfTestCases }
364args = defaultArgs { maxSuccess = noOfTestCases }
148
365
@@ -152,8 +369,3 @@ noOfTestCases = 20000
152#else
369#else
153noOfTestCases = 1000
370noOfTestCases = 1000
154#endif
371#endif
155−
156−#if !MIN_VERSION_servant(0,8,0)
157−comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
158−comprehensiveAPIWithoutRaw = comprehensiveAPI
159−#endif