git.iko.soy/servant-quickcheck
on 3f68561 help sign in
0535413
swap
0 ahead, 63 behind
.travis.yml+27−154
since splitsnapshots
unifiedsplit
@@ -1,158 +1,31 @@
1−# This Travis job script has been generated by a script via
1+sudo: false
2−#
2+
3−# haskell-ci '--config=cabal.haskell-ci' 'servant-quickcheck.cabal'
4−#
5−# To regenerate the script (for example after adjusting tested-with) run
6−#
7−# haskell-ci regenerate
8−#
9−# For more information, see https://github.com/haskell-CI/haskell-ci
10−#
11−# version: 0.10.1
12−#
13−version: ~> 1.0
14language: c
3language: c
15−os: linux
4+
16−dist: xenial
5+env:
17−git:
6+ - STACK_YAML=stack.yaml
18− # whether to recursively clone submodules
7+ - STACK_YAML=stack-lts-7.yaml
19− submodules: false
8+ - STACK_YAML=stack-lts-6.yaml
20−branches:
9+
21− only:
10+
22− - master
11+addons:
23−cache:
12+ apt:
24− directories:
13+ packages: libgmp-dev
25− - $HOME/.cabal/packages
14+
26− - $HOME/.cabal/store
15+
27− - $HOME/.hlint
28−before_cache:
29− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
30− # remove files that are regenerated by 'cabal update'
31− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
32− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
33− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
34− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
35− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
36− - rm -rfv $CABALHOME/packages/head.hackage
37−jobs:
38− include:
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
88install:
16install:
89− - ${CABAL} --version
17+ # stack
90− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
18+ - mkdir -p ~/.local/bin
91− - |
19+ - export PATH=~/.local/bin:$PATH
92− echo "program-default-options" >> $CABALHOME/config
20+ - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
93− echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
21+ - stack --version
94− - cat $CABALHOME/config
22+
95− - rm -fv cabal.project cabal.project.local cabal.project.freeze
96− - travis_retry ${CABAL} v2-update -v
97− # Generate cabal.project
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
114script:
23script:
115− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
24+ - stack setup --no-terminal
116− # Packaging...
25+ - stack build --ghc-options=-Werror --no-terminal
117− - ${CABAL} v2-sdist all
26+ - stack test --ghc-options=-Werror --no-terminal --coverage
118− # Unpacking...
27+ - stack haddock --no-terminal
119− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
120− - cd ${DISTDIR} || false
121− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
122− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
123− - PKGDIR_servant_quickcheck="$(find . -maxdepth 1 -type d -regex '.*/servant-quickcheck-[0-9.]*')"
124− # Generate cabal.project
125− - rm -rf cabal.project cabal.project.local cabal.project.freeze
126− - touch cabal.project
127− - |
128− echo "packages: ${PKGDIR_servant_quickcheck}" >> cabal.project
129− - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi
130− - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
131− - |
132− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-quickcheck)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"
133− - cat cabal.project || true
134− - cat cabal.project.local || true
135− # Building...
136− # this builds all libraries and executables (without tests/benchmarks)
137− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
138− # Building with tests and benchmarks...
139− # build & run tests, build benchmarks
140− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
141− # Testing...
142− - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all
143− # cabal check...
144− - (cd ${PKGDIR_servant_quickcheck} && ${CABAL} -vnormal check)
145− # haddock...
146− - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all
147− # Building without installed constraints for packages in global-db...
148− - rm -f cabal.project.local
149− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
150− # Constraint sets
151− - rm -rf cabal.project.local
152− # Constraint set base-compat-0.10
153− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.10.*' all
154− # Constraint set base-compat-0.11
155− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.11.*' all
156
28
157−# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","servant-quickcheck.cabal"])
29+cache:
158−# EOF
30+ directories:
31+ - $HOME/.stack
CHANGELOG.yaml+2−123
@@ -1,127 +1,6 @@
1−releases:
1+upcoming:
2− - version: "0.0.9.0"
3− changes:
4− - description: "Support servant-0.15 (#65)"
5− authors: fizruk
6− date: 2020-06-25
7−
8− - description: "Relax constraints for GHC 8.10 (#70)"
9− authors: felixmulder
10− date: 2020-06-20
11−
12− - version: "0.0.8.0"
13− changes:
14− - description: Support for servant-0.17
15− authors: phadej
16− date: 2019-01-23
17−
18− - version: "0.0.7.3"
19− changes:
20− - description: Support for servant-0.14
21− issue: 53
22− authors: phadej
23− date: 2018-06-12
24−
25− - description: Fix a failure from OnlyJsonObjects when there is no content-type.
26− issue: 55
27− authors: Phenitei
28− date: 2018-08-27
29−
30− - description: A bug fix where notAllowedContainsAllowHeader would print the initial request alongside the failure instead of the request causing the failure when it failed.
31− issue: 57
32− authors: Phenitei
33− date: 2018-08-29
34−
35− - description: QuickCheck 2.12 compatibility
36− issue: 58
37− authors: parsonsmatt
38− date: 2018-10-12
39−
40− - description: GHC 8.6 compatibility
41− issue: 59
42− authors: phadej
43− date: 2018-10-15
44−
45− - version: "0.0.7.2"
46− changes:
47−
48− - description: Allow client to pass an HTTP Manager in to functions
49− issue: 47
50− authors: parsonsmatt
51− date: 2018-05-10
52−
53− - description: Fix "should not happen" error when exceptions are thrown
54− issue: 48
55− authors: parsonsmatt
56− date: 2018-05-10
57−
58− - version: "0.0.7.0"
59− changes:
60−
61− - description: Support for base-compat-0.10
62− issue: none
63− authors: phadej
64− date: 2018-04-12
65−
66− - version: "0.0.7.0"
67− changes:
68
2
69− - description: Support for GHC-8.4.1
3+releases:
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
4
126 - version: "0.0.2.4"
5 - version: "0.0.2.4"
127 changes:
6 changes:
cabal.haskell-cideleted−7
@@ -1,7 +0,0 @@
1−branches: master
2−
3−constraint-set base-compat-0.10
4− constraints: base-compat ==0.10.*
5−
6−constraint-set base-compat-0.11
7− constraints: base-compat ==0.11.*
cabal.projectdeleted−4
@@ -1,4 +0,0 @@
1−packages: .
2−tests: true
3−
4−allow-newer: servant-blaze:servant
example/Main.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, DataKinds #-}
2−module Main (main) where
3−
4−import Servant
5−import Servant.QuickCheck
6−import Test.Hspec
7−import Data.Text (Text)
8−import System.Environment (getArgs)
9−
10−main :: IO ()
11−main = do
12− args <- getArgs
13− case args of
14− [] -> putStrLn "Not running without arguments. Try --help or --fail-fast."
15− _ -> hspec spec
16−
17−-- Change to String to reproduce
18−-- https://github.com/haskell-servant/servant-quickcheck/issues/41
19−type API = Get '[PlainText] Text
20−
21−api :: Proxy API
22−api = Proxy
23−
24−server :: Server API
25−server = return "Sigurð Fáfnirslayer"
26−
27−spec :: Spec
28−spec = describe "example server" $
29− it "mangles UTF-8 in error messages" $
30− withServantServer api (return server) $ \burl ->
31− serverSatisfies api burl defaultArgs (getsHaveCacheControlHeader <%> mempty)
servant-quickcheck.cabal+94−123
@@ -1,22 +1,22 @@
1−name: servant-quickcheck
1+name: servant-quickcheck
2−version: 0.0.9.1
2+version: 0.0.2.4
3−synopsis: QuickCheck entire APIs
3+synopsis: QuickCheck entire APIs
4description:
4description:
5− This packages provides QuickCheck properties that are tested across an entire
5+ This packages provides QuickCheck properties that are tested across an entire
6− API.
6+ API.
7
7
8−license: BSD3
8+license: BSD3
9−license-file: LICENSE
9+license-file: LICENSE
10−author: Julian K. Arni
10+author: Julian K. Arni
11−maintainer: jkarni@gmail.com
11+maintainer: jkarni@gmail.com
12−category: Web
12+category: Web
13−build-type: Simple
13+build-type: Simple
14−cabal-version: >=1.10
14+cabal-version: >=1.10
15−extra-source-files: CHANGELOG.yaml
15+extra-source-files:
16−tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3
16+ CHANGELOG.yaml
17
17
18source-repository head
18source-repository head
19− type: git
19+ type: git
20 location: https://github.com/haskell-servant/servant-quickcheck
20 location: https://github.com/haskell-servant/servant-quickcheck
21
21
22flag long-tests
22flag long-tests
@@ -24,115 +24,86 @@ flag long-tests
24 default: False
24 default: False
25
25
26library
26library
27− exposed-modules:
27+ exposed-modules: Servant.QuickCheck
28+ , Servant.QuickCheck.Internal
29+ , Servant.QuickCheck.Internal.Predicates
28− Servant.QuickCheck
30+ , Servant.QuickCheck.Internal.HasGenRequest
29− Servant.QuickCheck.Internal
31+ , Servant.QuickCheck.Internal.QuickCheck
30− Servant.QuickCheck.Internal.Equality
32+ , Servant.QuickCheck.Internal.Equality
31− Servant.QuickCheck.Internal.ErrorTypes
33+ , Servant.QuickCheck.Internal.ErrorTypes
32− Servant.QuickCheck.Internal.HasGenRequest
34+ build-depends: base >=4.8 && <4.10
35+ , base-compat == 0.9.*
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 && < 2.5
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
33− Servant.QuickCheck.Internal.Predicates
48+ , QuickCheck > 2.7 && < 2.11
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
35
58
36− build-depends:
37− aeson >=0.8 && <2
38− , base >=4.9 && <4.15
39− , base-compat-batteries >=0.10.1 && <0.12
40− , bytestring >=0.10 && <0.11
41− , case-insensitive >=1.2 && <1.3
42− , clock >=0.7 && <0.9
43− , data-default-class >=0.0 && <0.2
44− , hspec >=2.5.6 && <2.8
45− , http-client >=0.4.30 && <0.8
46− , http-media >=0.6 && <0.9
47− , http-types >=0.8 && <0.13
48− , mtl >=2.1 && <2.3
49− , pretty >=1.1 && <1.2
50− , process >=1.2 && <1.7
51− , QuickCheck >=2.7 && <2.15
52− , servant >=0.17 && <0.19
53− , servant-client >=0.17 && <0.19
54− , servant-server >=0.17 && <0.19
55− , split >=0.2 && <0.3
56− , string-conversions >=0.3 && <0.5
57− , temporary >=1.2 && <1.4
58− , text >=1 && <2
59− , time >=1.5 && <1.11
60− , warp >=3.2.4 && <3.4
61−
62− if !impl(ghc >=8.0)
63− build-depends: semigroups >=0.18.3 && <0.20
64−
65− hs-source-dirs: src
59+ hs-source-dirs: src
66− default-extensions:
60+ default-extensions: TypeOperators
67− NoImplicitPrelude
61+ , FlexibleInstances
68− ConstraintKinds
62+ , FlexibleContexts
69− DataKinds
63+ , DataKinds
70− DeriveDataTypeable
64+ , GADTs
65+ , MultiParamTypeClasses
71− DeriveFunctor
66+ , DeriveFunctor
72− DeriveGeneric
73− FlexibleContexts
74− FlexibleInstances
75− FunctionalDependencies
76− GADTs
77− KindSignatures
67+ , KindSignatures
78− MultiParamTypeClasses
79− OverloadedStrings
80− RankNTypes
68+ , RankNTypes
69+ , ConstraintKinds
70+ , DeriveGeneric
81− ScopedTypeVariables
71+ , ScopedTypeVariables
82− TypeOperators
72+ , OverloadedStrings
83−
73+ , FunctionalDependencies
74+ , NoImplicitPrelude
75+ , DeriveDataTypeable
84− default-language: Haskell2010
76+ default-language: Haskell2010
85
77
86test-suite spec
78test-suite spec
87− type: exitcode-stdio-1.0
79+ type: exitcode-stdio-1.0
88− ghc-options: -Wall -threaded
80+ ghc-options: -Wall -threaded
89− default-language: Haskell2010
81+ default-language: Haskell2010
90− hs-source-dirs: test
82+ hs-source-dirs: test
91− main-is: Spec.hs
83+ main-is: Spec.hs
92− other-modules: Servant.QuickCheck.InternalSpec
84+ other-modules: Servant.QuickCheck.InternalSpec
93− build-tool-depends: hspec-discover:hspec-discover -any
85+ build-depends: base == 4.*
94− build-depends:
95− aeson
96− , base
97− , base-compat-batteries
86+ , base-compat
98− , blaze-html
87+ , aeson
88+ , servant-quickcheck
99− , bytestring
89+ , bytestring
100− , hspec
90+ , hspec
101− , hspec-core >=2.5.5 && <2.8
91+ , hspec-core
102− , http-client
92+ , http-client
103− , QuickCheck
93+ , warp
104− , quickcheck-io
105− , servant
106− , servant-blaze
107− , servant-client
108− , servant-quickcheck
109− , servant-server
94+ , servant-server
95+ , servant-client
96+ , servant
110− , transformers
97+ , transformers
111− , warp
98+ , QuickCheck
112−
99+ , quickcheck-io
113− default-extensions:
100+ default-extensions: TypeOperators
114− NoImplicitPrelude
115− DataKinds
116− FlexibleContexts
117− FlexibleInstances
101+ , FlexibleInstances
102+ , FlexibleContexts
118− GADTs
103+ , GADTs
104+ , DataKinds
105+ , NoImplicitPrelude
119− OverloadedStrings
106+ , OverloadedStrings
120− ScopedTypeVariables
107+ , ScopedTypeVariables
121− TypeOperators
122−
123 if flag(long-tests)
108 if flag(long-tests)
124− cpp-options: -DLONG_TESTS
109+ 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−5
@@ -29,16 +29,11 @@ module Servant.QuickCheck
29 , not500
29 , not500
30 , notLongerThan
30 , notLongerThan
31 , onlyJsonObjects
31 , onlyJsonObjects
32− , honoursAcceptHeader
33 , notAllowedContainsAllowHeader
32 , notAllowedContainsAllowHeader
34 , unauthorizedContainsWWWAuthenticate
33 , unauthorizedContainsWWWAuthenticate
35− , getsHaveLastModifiedHeader
36 , getsHaveCacheControlHeader
34 , getsHaveCacheControlHeader
37 , headsHaveCacheControlHeader
35 , headsHaveCacheControlHeader
38 , createContainsValidLocation
36 , createContainsValidLocation
39− -- * Html Predicates
40− , htmlIncludesDoctype
41−
42 -- *** Predicate utilities and types
37 -- *** Predicate utilities and types
43 , (<%>)
38 , (<%>)
44 , Predicates
39 , Predicates
src/Servant/QuickCheck/Internal/Equality.hs+2−10
@@ -5,19 +5,15 @@ import Data.ByteString (ByteString)
5import qualified Data.ByteString.Lazy as LB
5import qualified Data.ByteString.Lazy as LB
6import Data.Function (on)
6import Data.Function (on)
7import Network.HTTP.Client (Response, responseBody)
7import Network.HTTP.Client (Response, responseBody)
8−import Data.Semigroup (Semigroup (..))
9import Prelude.Compat
8import Prelude.Compat
10
9
11newtype ResponseEquality b
10newtype ResponseEquality b
12 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
11 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }
13
12
14−instance Semigroup (ResponseEquality b) where
15− ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y ->
16− a x y && b x y
17−
18instance Monoid (ResponseEquality b) where
13instance Monoid (ResponseEquality b) where
19 mempty = ResponseEquality $ \_ _ -> True
14 mempty = ResponseEquality $ \_ _ -> True
20− mappend = (<>)
15+ ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->
16+ a x y && b x y
21
17
22-- | Use `Eq` instance for `Response`
18-- | Use `Eq` instance for `Response`
23--
19--
@@ -31,10 +27,6 @@ allEquality = ResponseEquality (==)
31bodyEquality :: Eq b => ResponseEquality b
27bodyEquality :: Eq b => ResponseEquality b
32bodyEquality = ResponseEquality ((==) `on` responseBody)
28bodyEquality = ResponseEquality ((==) `on` responseBody)
33
29
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/
38jsonEquality :: (JsonEq b) => ResponseEquality b
30jsonEquality :: (JsonEq b) => ResponseEquality b
39jsonEquality = ResponseEquality (jsonEq `on` responseBody)
31jsonEquality = ResponseEquality (jsonEq `on` responseBody)
40
32
src/Servant/QuickCheck/Internal/ErrorTypes.hs+1−3
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2module Servant.QuickCheck.Internal.ErrorTypes where
1module Servant.QuickCheck.Internal.ErrorTypes where
3
2
4import Control.Exception (Exception (..))
3import Control.Exception (Exception (..))
@@ -9,10 +8,9 @@ import Data.Typeable (Typeable)
9import GHC.Generics (Generic)
8import GHC.Generics (Generic)
10import qualified Network.HTTP.Client as C
9import qualified Network.HTTP.Client as C
11import Network.HTTP.Types (Header, statusCode)
10import Network.HTTP.Types (Header, statusCode)
11+import Prelude.Compat
12import Text.PrettyPrint
12import Text.PrettyPrint
13
13
14−import Prelude.Compat hiding ((<>))
15−
16data PredicateFailure
14data PredicateFailure
17 = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
15 = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
18 deriving (Typeable, Generic)
16 deriving (Typeable, Generic)
src/Servant/QuickCheck/Internal/HasGenRequest.hs+10−24
@@ -2,6 +2,7 @@
2{-# LANGUAGE PolyKinds #-}
2{-# LANGUAGE PolyKinds #-}
3module Servant.QuickCheck.Internal.HasGenRequest where
3module Servant.QuickCheck.Internal.HasGenRequest where
4
4
5+import Data.Monoid ((<>))
5import Data.String (fromString)
6import Data.String (fromString)
6import Data.String.Conversions (cs)
7import Data.String.Conversions (cs)
7import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
8import GHC.TypeLits (KnownSymbol, Nat, symbolVal)
@@ -63,17 +64,9 @@ instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
63 (oldf, old) = genRequest (Proxy :: Proxy b)
64 (oldf, old) = genRequest (Proxy :: Proxy b)
64 new = cs $ symbolVal (Proxy :: Proxy path)
65 new = cs $ symbolVal (Proxy :: Proxy path)
65
66
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
67
75instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
68instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
76− => HasGenRequest (Capture' mods x c :> b) where
69+ => HasGenRequest (Capture x c :> b) where
77 genRequest _ = (oldf, do
70 genRequest _ = (oldf, do
78 old' <- old
71 old' <- old
79 new' <- toUrlPiece <$> new
72 new' <- toUrlPiece <$> new
@@ -82,6 +75,7 @@ instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
82 (oldf, old) = genRequest (Proxy :: Proxy b)
75 (oldf, old) = genRequest (Proxy :: Proxy b)
83 new = arbitrary :: Gen c
76 new = arbitrary :: Gen c
84
77
78+#if MIN_VERSION_servant(0,8,0)
85instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
79instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
86 => HasGenRequest (CaptureAll x c :> b) where
80 => HasGenRequest (CaptureAll x c :> b) where
87 genRequest _ = (oldf, do
81 genRequest _ = (oldf, do
@@ -92,12 +86,13 @@ instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
92 where
86 where
93 (oldf, old) = genRequest (Proxy :: Proxy b)
87 (oldf, old) = genRequest (Proxy :: Proxy b)
94 new = arbitrary :: Gen [c]
88 new = arbitrary :: Gen [c]
89+#endif
95
90
96instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
91instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
97− => HasGenRequest (Header' mods h c :> b) where
92+ => HasGenRequest (Header h c :> b) where
98 genRequest _ = (oldf, do
93 genRequest _ = (oldf, do
99 old' <- old
94 old' <- old
100− new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
95+ new' <- toUrlPiece <$> new
101 return $ \burl -> let r = old' burl in r {
96 return $ \burl -> let r = old' burl in r {
102 requestHeaders = (hdr, cs new') : requestHeaders r })
97 requestHeaders = (hdr, cs new') : requestHeaders r })
103 where
98 where
@@ -106,9 +101,9 @@ instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
106 new = arbitrary :: Gen c
101 new = arbitrary :: Gen c
107
102
108instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
103instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
109− => HasGenRequest (ReqBody' mods x c :> b) where
104+ => HasGenRequest (ReqBody x c :> b) where
110 genRequest _ = (oldf, do
105 genRequest _ = (oldf, do
111− old' <- old -- TODO: generate lenient
106+ old' <- old
112 new' <- new
107 new' <- new
113 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
108 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
114 return $ \burl -> let r = old' burl in r {
109 return $ \burl -> let r = old' burl in r {
@@ -120,9 +115,9 @@ instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
120 new = arbitrary :: Gen c
115 new = arbitrary :: Gen c
121
116
122instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
117instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
123− => HasGenRequest (QueryParam' mods x c :> b) where
118+ => HasGenRequest (QueryParam x c :> b) where
124 genRequest _ = (oldf, do
119 genRequest _ = (oldf, do
125− new' <- new -- TODO: generate lenient or/and optional
120+ new' <- new
126 old' <- old
121 old' <- old
127 return $ \burl -> let r = old' burl
122 return $ \burl -> let r = old' burl
128 newExpr = param <> "=" <> cs (toQueryParam new')
123 newExpr = param <> "=" <> cs (toQueryParam new')
@@ -168,15 +163,6 @@ instance (ReflectMethod method)
168 , method = reflectMethod (Proxy :: Proxy method)
163 , method = reflectMethod (Proxy :: Proxy method)
169 })
164 })
170
165
171−instance (ReflectMethod method)
172− => HasGenRequest (NoContentVerb (method :: k)) where
173− genRequest _ = (1, return $ \burl -> defaultRequest
174− { host = cs $ baseUrlHost burl
175− , port = baseUrlPort burl
176− , secure = baseUrlScheme burl == Https
177− , method = reflectMethod (Proxy :: Proxy method)
178− })
179−
180instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
166instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
181 genRequest _ = genRequest (Proxy :: Proxy a)
167 genRequest _ = genRequest (Proxy :: Proxy a)
182
168
src/Servant/QuickCheck/Internal/Predicates.hs+31−63
@@ -7,12 +7,11 @@ import Data.Bifunctor (first)
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 (foldCase, foldedCase, mk)
10+import Data.CaseInsensitive (mk, foldedCase)
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.Semigroup (Semigroup (..))
14+import Data.Monoid ((<>))
15−import qualified Data.Text as T
16import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
15import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
17 rfc822DateFormat)
16 rfc822DateFormat)
18import GHC.Generics (Generic)
17import GHC.Generics (Generic)
@@ -43,7 +42,7 @@ import Servant.QuickCheck.Internal.ErrorTypes
43-- /Since 0.0.0.0/
42-- /Since 0.0.0.0/
44not500 :: ResponsePredicate
43not500 :: ResponsePredicate
45not500 = ResponsePredicate $ \resp ->
44not500 = ResponsePredicate $ \resp ->
46− when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
45+ when (responseStatus resp == status500) $ fail "not500"
47
46
48-- | [__Optional__]
47-- | [__Optional__]
49--
48--
@@ -84,13 +83,15 @@ notLongerThan maxAllowed
84-- /Since 0.0.0.0/
83-- /Since 0.0.0.0/
85onlyJsonObjects :: ResponsePredicate
84onlyJsonObjects :: ResponsePredicate
86onlyJsonObjects
85onlyJsonObjects
87− = ResponsePredicate (\resp -> do
86+ = ResponsePredicate (\resp -> case go resp of
87+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
88+ Just () -> return ())
89+ where
90+ go r = do
88− case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
91+ ctyp <- lookup "content-type" (first foldedCase <$> responseHeaders r)
89− Nothing -> return ()
90− Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do
92+ when ("application/json" `SBS.isPrefixOf` ctyp) $ do
91− case (decode (responseBody resp) :: Maybe Object) of
93+ (_ :: Object) <- decode (responseBody r)
92− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
93− Just _ -> return ())
94+ return ()
94
95
95-- | __Optional__
96-- | __Optional__
96--
97--
@@ -118,12 +119,12 @@ createContainsValidLocation
118 resp <- httpLbs req mgr
119 resp <- httpLbs req mgr
119 if responseStatus resp == status201
120 if responseStatus resp == status201
120 then case lookup "Location" $ responseHeaders resp of
121 then case lookup "Location" $ responseHeaders resp of
121− Nothing -> throw $ PredicateFailure n (Just req) resp
122+ Nothing -> fail n
122 Just l -> case parseRequest $ SBSC.unpack l of
123 Just l -> case parseRequest $ SBSC.unpack l of
123− Nothing -> throw $ PredicateFailure n (Just req) resp
124+ Nothing -> fail n
124 Just x -> do
125 Just x -> do
125 resp2 <- httpLbs x mgr
126 resp2 <- httpLbs x mgr
126− status2XX (Just req) resp2 n
127+ status2XX resp2 n
127 return [resp, resp2]
128 return [resp, resp2]
128 else return [resp]
129 else return [resp]
129
130
@@ -187,15 +188,14 @@ getsHaveLastModifiedHeader
187notAllowedContainsAllowHeader :: RequestPredicate
188notAllowedContainsAllowHeader :: RequestPredicate
188notAllowedContainsAllowHeader
189notAllowedContainsAllowHeader
189 = RequestPredicate $ \req mgr -> do
190 = RequestPredicate $ \req mgr -> do
190− let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
191+ resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
192+ | m <- [minBound .. maxBound ]
191− , renderStdMethod m /= method req ]
193+ , renderStdMethod m /= method req ]
192− resp <- mapM (flip httpLbs mgr) reqs
193−
194− case filter pred' (zip reqs resp) of
194+ case filter pred' resp of
195− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
195+ (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
196 [] -> return resp
196 [] -> return resp
197 where
197 where
198− pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
198+ pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
199 where
199 where
200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@@ -225,7 +225,7 @@ honoursAcceptHeader
225 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
225 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
226 if status100 < scode && scode < status300
226 if status100 < scode && scode < status300
227 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
227 then if isJust $ sctype >>= \x -> matchAccept [x] sacc
228− then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
228+ then fail "honoursAcceptHeader"
229 else return [resp]
229 else return [resp]
230 else return [resp]
230 else return [resp]
231
231
@@ -336,29 +336,7 @@ unauthorizedContainsWWWAuthenticate
336 = ResponsePredicate $ \resp ->
336 = ResponsePredicate $ \resp ->
337 if responseStatus resp == status401
337 if responseStatus resp == status401
338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
339− throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
339+ fail "unauthorizedContainsWWWAuthenticate"
340− else return ()
341−
342−
343−-- | [__RFC Compliance__]
344−--
345−-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
346−--
347−-- This function checks that HTML documents (those with `Content-Type: text/html...`)
348−-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
349−--
350−-- __References__:
351−--
352−-- * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
353−-- /Since 0.3.0.0/
354−htmlIncludesDoctype :: ResponsePredicate
355−htmlIncludesDoctype
356− = ResponsePredicate $ \resp ->
357− if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
358− then do
359− let htmlContent = foldCase . LBS.take 20 $ responseBody resp
360− unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
361− throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
362 else return ()
340 else return ()
363
341
364-- * Predicate logic
342-- * Predicate logic
@@ -376,12 +354,9 @@ newtype ResponsePredicate = ResponsePredicate
376 { getResponsePredicate :: Response LBS.ByteString -> IO ()
354 { getResponsePredicate :: Response LBS.ByteString -> IO ()
377 } deriving (Generic)
355 } deriving (Generic)
378
356
379−instance Semigroup ResponsePredicate where
380− ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
381−
382instance Monoid ResponsePredicate where
357instance Monoid ResponsePredicate where
383 mempty = ResponsePredicate $ const $ return ()
358 mempty = ResponsePredicate $ const $ return ()
384− mappend = (<>)
359+ ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
385
360
386-- | A predicate that depends on both the request and the response.
361-- | A predicate that depends on both the request and the response.
387--
362--
@@ -393,11 +368,7 @@ newtype RequestPredicate = RequestPredicate
393-- TODO: This isn't actually a monoid
368-- TODO: This isn't actually a monoid
394instance Monoid RequestPredicate where
369instance Monoid RequestPredicate where
395 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
370 mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
396− mappend = (<>)
397−
398−-- TODO: This isn't actually a monoid
399−instance Semigroup RequestPredicate where
400− RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
371+ RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
401 liftM2 (<>) (a r mgr) (b r mgr)
372 liftM2 (<>) (a r mgr) (b r mgr)
402
373
403-- | A set of predicates. Construct one with 'mempty' and '<%>'.
374-- | A set of predicates. Construct one with 'mempty' and '<%>'.
@@ -406,13 +377,10 @@ data Predicates = Predicates
406 , responsePredicates :: ResponsePredicate
377 , responsePredicates :: ResponsePredicate
407 } deriving (Generic)
378 } deriving (Generic)
408
379
409−instance Semigroup Predicates where
410− a <> b = Predicates (requestPredicates a <> requestPredicates b)
411− (responsePredicates a <> responsePredicates b)
412−
413instance Monoid Predicates where
380instance Monoid Predicates where
414 mempty = Predicates mempty mempty
381 mempty = Predicates mempty mempty
415− mappend = (<>)
382+ a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
383+ (responsePredicates a <> responsePredicates b)
416
384
417class JoinPreds a where
385class JoinPreds a where
418 joinPreds :: a -> Predicates -> Predicates
386 joinPreds :: a -> Predicates -> Predicates
@@ -454,8 +422,8 @@ isRFC822Date s
454 Nothing -> False
422 Nothing -> False
455 Just (_ :: UTCTime) -> True
423 Just (_ :: UTCTime) -> True
456
424
457−status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
425+status2XX :: Monad m => Response b -> String -> m ()
458−status2XX mreq resp t
426+status2XX r t
459− | status200 <= responseStatus resp && responseStatus resp < status300
427+ | status200 <= responseStatus r && responseStatus r < status300
460 = return ()
428 = return ()
461− | otherwise = throw $ PredicateFailure t mreq resp
429+ | otherwise = fail t
src/Servant/QuickCheck/Internal/QuickCheck.hs+19−58
@@ -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 (tryReadMVar, newEmptyMVar, tryPutMVar)
5+import Control.Concurrent (modifyMVar_, newMVar, readMVar)
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,9 +11,6 @@ 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
17import Servant.Client (BaseUrl (..), Scheme (..))
14import Servant.Client (BaseUrl (..), Scheme (..))
18import System.IO.Unsafe (unsafePerformIO)
15import System.IO.Unsafe (unsafePerformIO)
19import Test.Hspec (Expectation, expectationFailure)
16import Test.Hspec (Expectation, expectationFailure)
@@ -40,11 +37,7 @@ withServantServer api = withServantServerAndContext api EmptyContext
40-- application.
37-- application.
41--
38--
42-- /Since 0.0.0.0/
39-- /Since 0.0.0.0/
43−#if MIN_VERSION_servant_server(0,18,0)
44−withServantServerAndContext :: (HasServer a ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters)
45−#else
46withServantServerAndContext :: HasServer a ctx
40withServantServerAndContext :: HasServer a ctx
47−#endif
48 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
41 => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
49withServantServerAndContext api ctx server t
42withServantServerAndContext api ctx server t
50 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
43 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
@@ -80,29 +73,21 @@ serversEqual api burl1 burl2 args req = do
80 let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
73 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
74 -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
82 -- return results when a test fails, since an exception is throw.
75 -- return results when a test fails, since an exception is throw.
83− deetsMVar <- newEmptyMVar
76+ deetsMVar <- newMVar $ error "should not be called"
84 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
77 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
85 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
78 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
86 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
79 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
87 unless (getResponseEquality req resp1 resp2) $ do
80 unless (getResponseEquality req resp1 resp2) $ do
88 monitor (counterexample "hi" )
81 monitor (counterexample "hi" )
82+ run $ modifyMVar_ deetsMVar $ const $ return $
89− _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
83+ ServerEqualityFailure req1 resp1 resp2
90 assert False
84 assert False
91 case r of
85 case r of
92 Success {} -> return ()
86 Success {} -> return ()
93− Failure{..} -> do
94− mx <- tryReadMVar deetsMVar
95− case mx of
96− Just x ->
97− expectationFailure $ "Failed:\n" ++ show x
87+ Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x
98− Nothing ->
99− expectationFailure $ "We failed to record a reason for failure: " <> show r
100 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
88 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
101 NoExpectedFailure {} -> expectationFailure "No expected failure"
89 NoExpectedFailure {} -> expectationFailure "No expected failure"
102−#if MIN_VERSION_QuickCheck(2,12,0)
103−#else
104 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
90 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
105−#endif
106
91
107-- | Check that a server satisfies the set of properties specified.
92-- | Check that a server satisfies the set of properties specified.
108--
93--
@@ -125,61 +110,37 @@ serversEqual api burl1 burl2 args req = do
125-- /Since 0.0.0.0/
110-- /Since 0.0.0.0/
126serverSatisfies :: (HasGenRequest a) =>
111serverSatisfies :: (HasGenRequest a) =>
127 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
112 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
128−serverSatisfies api = serverSatisfiesMgr api defManager
113+serverSatisfies api burl args preds = do
129−
130−-- | Check that a server satisfies the set of properties specified, and
131−-- accept a 'Manager' for running the HTTP requests through.
132−--
133−-- See 'serverSatisfies' for more details.
134−--
135−-- @since 0.0.7.2
136−serverSatisfiesMgr :: (HasGenRequest a) =>
137− Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
138−serverSatisfiesMgr api manager burl args preds = do
139 let reqs = ($ burl) <$> runGenRequest api
114 let reqs = ($ burl) <$> runGenRequest api
140− deetsMVar <- newEmptyMVar
115+ deetsMVar <- newMVar $ error "should not be called"
141 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
116 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
142− v <- run $ finishPredicates preds (noCheckStatus req) manager
117+ v <- run $ finishPredicates preds (noCheckStatus req) defManager
143− _ <- run $ tryPutMVar deetsMVar v
118+ run $ modifyMVar_ deetsMVar $ const $ return v
144− case v of
119+ case v of
145− Just _ -> assert False
120+ Just _ -> assert False
146− _ -> return ()
121+ _ -> return ()
147 case r of
122 case r of
148 Success {} -> return ()
123 Success {} -> return ()
149− Failure {..} -> do
124+ Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
150− mx <- tryReadMVar deetsMVar
151− case mx of
152− Just x ->
153− expectationFailure $ "Failed:\n" ++ show x
125+ "Failed:\n" ++ show x
154− Nothing ->
155− expectationFailure $ "We failed to record a reason for failure: " <> show r
156 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
126 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
157 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
127 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
158−#if MIN_VERSION_QuickCheck(2,12,0)
159−#else
160− InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
128+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
161−#endif
129+
162
130
163serverDoesntSatisfy :: (HasGenRequest a) =>
131serverDoesntSatisfy :: (HasGenRequest a) =>
164 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
132 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
165−serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
133+serverDoesntSatisfy api burl args preds = do
166−
167−serverDoesntSatisfyMgr :: (HasGenRequest a) =>
168− Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
169−serverDoesntSatisfyMgr api manager burl args preds = do
170 let reqs = ($ burl) <$> runGenRequest api
134 let reqs = ($ burl) <$> runGenRequest api
171 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
135 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
172− v <- run $ finishPredicates preds (noCheckStatus req) manager
136+ v <- run $ finishPredicates preds (noCheckStatus req) defManager
173 assert $ not $ null v
137 assert $ not $ null v
174 case r of
138 case r of
175 Success {} -> return ()
139 Success {} -> return ()
176 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
140 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
177 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
141 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
178 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
142 NoExpectedFailure {} -> expectationFailure $ "No expected failure"
179−#if MIN_VERSION_QuickCheck(2,12,0)
180−#else
181− InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
143+ InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
182−#endif
183
144
184noCheckStatus :: C.Request -> C.Request
145noCheckStatus :: C.Request -> C.Request
185#if MIN_VERSION_http_client(0,5,0)
146#if MIN_VERSION_http_client(0,5,0)
stack-lts-6.yamlnew file+6
@@ -0,0 +1,6 @@
1+resolver: lts-6.30
2+packages:
3+- '.'
4+extra-deps: []
5+flags: {}
6+extra-package-dbs: []
stack-lts-7.yamlnew file+6
@@ -0,0 +1,6 @@
1+resolver: lts-7.19
2+packages:
3+- '.'
4+extra-deps: []
5+flags: {}
6+extra-package-dbs: []
stack.yaml+5−5
@@ -1,10 +1,10 @@
1−resolver: nightly-2018-09-03
1+resolver: lts-8.4
2packages:
2packages:
3- '.'
3- '.'
4extra-deps:
4extra-deps:
5+- hspec-2.4.4
6+- hspec-core-2.4.4
5−- hspec-discover-2.5.6
7+- hspec-discover-2.4.4
6−- hspec-core-2.5.6
8+- quickcheck-io-0.2.0
7−- hspec-2.5.6
8−- QuickCheck-2.12
9flags: {}
9flags: {}
10extra-package-dbs: []
10extra-package-dbs: []
test/Doctest.hsnew file+44
@@ -0,0 +1,44 @@
1+module Main where
2+
3+import Data.List (isPrefixOf)
4+import System.Directory
5+import System.FilePath
6+import System.FilePath.Find
7+import Test.DocTest
8+
9+main :: IO ()
10+main = do
11+ files <- find always (extension ==? ".hs") "src"
12+ mCabalMacrosFile <- getCabalMacrosFile
13+ doctest $ "-isrc" : "-Iinclude" :
14+ (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
15+ "-XOverloadedStrings" :
16+ "-XDeriveFunctor" :
17+ "-XFlexibleInstances" :
18+ "-XFlexibleContexts" :
19+ "-XMultiParamTypeClasses" :
20+ "-XDataKinds" :
21+ "-XTypeOperators" :
22+ "-XGADTs" :
23+ files
24+
25+getCabalMacrosFile :: IO (Maybe FilePath)
26+getCabalMacrosFile = do
27+ exists <- doesDirectoryExist "dist"
28+ if exists
29+ then do
30+ contents <- getDirectoryContents "dist"
31+ let rest = "build" </> "autogen" </> "cabal_macros.h"
32+ whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
33+ [x] -> "dist" </> x </> rest
34+ [] -> "dist" </> rest
35+ xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
36+ ++ show xs ++ "\nTry cabal clean"
37+ else return Nothing
38+ where
39+ whenExists :: FilePath -> IO (Maybe FilePath)
40+ whenExists file = do
41+ exists <- doesFileExist file
42+ return $ if exists
43+ then Just file
44+ else Nothing
test/Servant/QuickCheck/InternalSpec.hs+45−57
@@ -12,23 +12,33 @@ import Data.Maybe (fromJust)
12import Network.HTTP.Client (path, queryString)
12import Network.HTTP.Client (path, queryString)
13import Prelude.Compat
13import Prelude.Compat
14import Servant
14import Servant
15−import Servant.HTML.Blaze (HTML)
16−import qualified Text.Blaze.Html as Blaze
17−import qualified Text.Blaze.Html5 as Blaze5
18import Test.Hspec (Spec, context, describe, it, shouldBe,
15import Test.Hspec (Spec, context, describe, it, shouldBe,
19 shouldContain)
16 shouldContain)
20−import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),
17+import Test.Hspec.Core.Spec (Arg, Example, Result (..),
21− defaultParams, safeEvaluateExample)
18+ defaultParams)
22import Test.QuickCheck.Gen (generate, unGen)
19import Test.QuickCheck.Gen (generate, unGen)
23import Test.QuickCheck.Random (mkQCGen)
20import Test.QuickCheck.Random (mkQCGen)
24
21
25
22
23+#if MIN_VERSION_servant(0,8,0)
26−import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)
24+import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
25+#else
26+import Servant.API.Internal.Test.ComprehensiveAPI (ComprehensiveAPI,
27+ comprehensiveAPI)
28+#endif
29+
30+#if MIN_VERSION_hspec(2,4,0)
31+import Test.Hspec.Core.Spec (safeEvaluateExample)
32+#else
33+import Control.Exception (try)
34+import Test.Hspec.Core.Spec (evaluateExample)
35+#endif
27
36
28import Servant.QuickCheck
37import Servant.QuickCheck
29import Servant.QuickCheck.Internal (genRequest, runGenRequest,
38import Servant.QuickCheck.Internal (genRequest, runGenRequest,
30 serverDoesntSatisfy)
39 serverDoesntSatisfy)
31
40
41+
32spec :: Spec
42spec :: Spec
33spec = do
43spec = do
34 serversEqualSpec
44 serversEqualSpec
@@ -39,7 +49,6 @@ spec = do
39 queryParamsSpec
49 queryParamsSpec
40 queryFlagsSpec
50 queryFlagsSpec
41 deepPathSpec
51 deepPathSpec
42− htmlDocTypesSpec
43 unbiasedGenerationSpec
52 unbiasedGenerationSpec
44
53
45serversEqualSpec :: Spec
54serversEqualSpec :: Spec
@@ -63,9 +72,9 @@ serversEqualSpec = describe "serversEqual" $ do
63 context "when JSON is equal but looks a bit different as a ByteString" $ do
72 context "when JSON is equal but looks a bit different as a ByteString" $ do
64
73
65 it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
74 it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
66− FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
75+ Right (Failure _ err) <- withServantServer jsonApi jsonServer1 $ \burl1 ->
67 withServantServer jsonApi jsonServer2 $ \burl2 -> do
76 withServantServer jsonApi jsonServer2 $ \burl2 -> do
68− evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
77+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
69 show err `shouldContain` "Server equality failed"
78 show err `shouldContain` "Server equality failed"
70
79
71 it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
80 it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
@@ -74,16 +83,16 @@ serversEqualSpec = describe "serversEqual" $ do
74 serversEqual jsonApi burl1 burl2 args jsonEquality
83 serversEqual jsonApi burl1 burl2 args jsonEquality
75
84
76 it "sees when JSON apis are not equal because any value is different" $ do
85 it "sees when JSON apis are not equal because any value is different" $ do
77− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
86+ Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
78 withServantServer jsonApi jsonServer3 $ \burl2 -> do
87 withServantServer jsonApi jsonServer3 $ \burl2 -> do
79− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
88+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
80 show err `shouldContain` "Server equality failed"
89 show err `shouldContain` "Server equality failed"
81 show err `shouldContain` "Path: /jsonComparison"
90 show err `shouldContain` "Path: /jsonComparison"
82
91
83 it "sees when JSON apis are not equal due to different keys but same values" $ do
92 it "sees when JSON apis are not equal due to different keys but same values" $ do
84− FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
93+ Right (Failure _ err) <- withServantServer jsonApi jsonServer2 $ \burl1 ->
85 withServantServer jsonApi jsonServer4 $ \burl2 -> do
94 withServantServer jsonApi jsonServer4 $ \burl2 -> do
86− evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
95+ safeEvalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
87 show err `shouldContain` "Server equality failed"
96 show err `shouldContain` "Server equality failed"
88 show err `shouldContain` "Path: /jsonComparison"
97 show err `shouldContain` "Path: /jsonComparison"
89
98
@@ -128,10 +137,6 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
128 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
137 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
129 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
138 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
130
139
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−
135notLongerThanSpec :: Spec
140notLongerThanSpec :: Spec
136notLongerThanSpec = describe "notLongerThan" $ do
141notLongerThanSpec = describe "notLongerThan" $ do
137
142
@@ -149,7 +154,7 @@ isComprehensiveSpec :: Spec
149isComprehensiveSpec = describe "HasGenRequest" $ do
154isComprehensiveSpec = describe "HasGenRequest" $ do
150
155
151 it "has instances for all 'servant' combinators" $ do
156 it "has instances for all 'servant' combinators" $ do
152− let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
157+ let _g = genRequest comprehensiveAPIWithoutRaw
153 True `shouldBe` True -- This is a type-level check
158 True `shouldBe` True -- This is a type-level check
154
159
155deepPathSpec :: Spec
160deepPathSpec :: Spec
@@ -185,25 +190,6 @@ queryFlagsSpec = describe "QueryFlags" $ do
185 qs = C.unpack $ queryString req
190 qs = C.unpack $ queryString req
186 qs `shouldBe` "one&two"
191 qs `shouldBe` "one&two"
187
192
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−
207makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
193makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
208makeRandomRequest large burl = do
194makeRandomRequest large burl = do
209 req <- generate $ runGenRequest large
195 req <- generate $ runGenRequest large
@@ -273,23 +259,7 @@ server2 = return $ return 1
273server3 :: IO (Server API2)
259server3 :: IO (Server API2)
274server3 = return $ return 2
260server3 = return $ return 2
275
261
276−serverFailing :: IO (Server API2)
277−serverFailing = return . throwError $ err405
278
262
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
293largeApi :: Proxy LargeAPI
263largeApi :: Proxy LargeAPI
294largeApi = Proxy
264largeApi = Proxy
295
265
@@ -344,14 +314,27 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
344-- Utils
314-- Utils
345------------------------------------------------------------------------------
315------------------------------------------------------------------------------
346evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
316evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
317+#if MIN_VERSION_hspec(2,4,0)
347evalExample e = do
318evalExample e = do
348 r <- safeEvaluateExample e defaultParams ($ ()) progCallback
319 r <- safeEvaluateExample e defaultParams ($ ()) progCallback
349− case resultStatus r of
320+ case r of
321+ Left err -> return $ AnException err
350− Success -> return $ AllGood
322+ Right Success -> return $ AllGood
351− Failure _ reason -> return $ FailedWith $ show reason
323+ Right (Failure _ reason) -> return $ FailedWith $ show reason
324+ Right (Pending _) -> error "should not happen"
325+ where
326+ progCallback _ = return ()
327+#else
328+evalExample e = do
329+ r <- try $ evaluateExample e defaultParams ($ ()) progCallback
330+ case r of
331+ Left err -> return $ AnException err
332+ Right Success -> return $ AllGood
333+ Right (Fail _ reason) -> return $ FailedWith reason
352− Pending {} -> error "should not happen"
334+ Right (Pending _) -> error "should not happen"
353 where
335 where
354 progCallback _ = return ()
336 progCallback _ = return ()
337+#endif
355
338
356data EvalResult
339data EvalResult
357 = AnException SomeException
340 = AnException SomeException
@@ -369,3 +352,8 @@ noOfTestCases = 20000
369#else
352#else
370noOfTestCases = 1000
353noOfTestCases = 1000
371#endif
354#endif
355+
356+#if !MIN_VERSION_servant(0,8,0)
357+comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI
358+comprehensiveAPIWithoutRaw = comprehensiveAPI
359+#endif