2c1152a..master · servant-quickcheck

git.iko.soy/servant-quickcheck

on master help sign in

.gitignore+1

since splitsnapshots

unifiedsplit

@@ -3,3 +3,4 @@ scripts/

3samples/

4test-servers/

5/doc/

6+.stack-work/

.travis.yml+154−30

@@ -1,34 +1,158 @@

1−sudo: false

1+# This Travis job script has been generated by a script via

2−

2+#

3+# haskell-ci '--config=cabal.haskell-ci' 'servant-quickcheck.cabal'

4+#

5+# To regenerate the script (for example after adjusting tested-with) run

6+#

7+# haskell-ci regenerate

8+#

9+# For more information, see https://github.com/haskell-CI/haskell-ci

10+#

11+# version: 0.10.1

12+#

13+version: ~> 1.0

3language: c

14language: c

4−

15+os: linux

5−env:

16+dist: xenial

6− - GHCVER=7.8.4

17+git:

7− - GHCVER=7.10.2

18+ # whether to recursively clone submodules

8−

19+ submodules: false

9−addons:

20+branches:

10− apt:

21+ only:

11− sources:

22+ - master

12− - hvr-ghc

23+cache:

13− packages:

24+ directories:

14− - ghc-7.8.4

25+ - $HOME/.cabal/packages

15− - ghc-7.10.2

26+ - $HOME/.cabal/store

16− - cabal-install-1.22

27+ - $HOME/.hlint

17− - libgmp-dev

28+before_cache:

18− - wrk

29+ - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

19−

30+ # remove files that are regenerated by 'cabal update'

31+ - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

32+ - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

33+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

34+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

35+ - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

36+ - rm -rfv $CABALHOME/packages/head.hackage

37+jobs:

38+ include:

39+ - compiler: ghc-8.8.3

40+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.3","cabal-install-3.2"]}}

41+ os: linux

42+ - compiler: ghc-8.6.5

43+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}}

44+ os: linux

45+ - compiler: ghc-8.4.4

46+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}}

47+ os: linux

48+ - compiler: ghc-8.2.2

49+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}}

50+ os: linux

51+ - compiler: ghc-8.0.2

52+ addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}}

53+ os: linux

54+before_install:

55+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')

56+ - WITHCOMPILER="-w $HC"

57+ - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')

58+ - HCPKG="$HC-pkg"

59+ - unset CC

60+ - CABAL=/opt/ghc/bin/cabal

61+ - CABALHOME=$HOME/.cabal

62+ - export PATH="$CABALHOME/bin:$PATH"

63+ - TOP=$(pwd)

64+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"

65+ - echo $HCNUMVER

66+ - CABAL="$CABAL -vnormal+nowrap"

67+ - set -o pipefail

68+ - TEST=--enable-tests

69+ - BENCH=--enable-benchmarks

70+ - HEADHACKAGE=false

71+ - rm -f $CABALHOME/config

72+ - |

73+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config

74+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config

75+ echo "write-ghc-environment-files: always" >> $CABALHOME/config

76+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config

77+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config

78+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config

79+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config

80+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config

81+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config

82+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config

83+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config

84+ echo "install-dirs user" >> $CABALHOME/config

85+ echo " prefix: $CABALHOME" >> $CABALHOME/config

86+ echo "repository hackage.haskell.org" >> $CABALHOME/config

87+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config

20install:

88install:

21− - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)

89+ - ${CABAL} --version

22− - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH

90+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

23− - ghc --version

91+ - |

24− - cabal --version

92+ echo "program-default-options" >> $CABALHOME/config

93+ echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config

94+ - cat $CABALHOME/config

95+ - rm -fv cabal.project cabal.project.local cabal.project.freeze

25− - travis_retry cabal update

96+ - travis_retry ${CABAL} v2-update -v

26− - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

97+ # Generate cabal.project

27−

98+ - rm -rf cabal.project cabal.project.local cabal.project.freeze

99+ - touch cabal.project

100+ - |

101+ echo "packages: ." >> cabal.project

102+ - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi

103+ - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

104+ - |

105+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-quickcheck)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

106+ - cat cabal.project || true

107+ - cat cabal.project.local || true

108+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

109+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}

110+ - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

111+ - rm cabal.project.freeze

112+ - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all

113+ - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all

28script:

114script:

29− - tinc && cabal configure --enable-tests && cabal build && cabal test

115+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

30− #- (cd doc && tinc cabal configure --enable-tests && cabal build && cabal test)

116+ # Packaging...

117+ - ${CABAL} v2-sdist all

118+ # Unpacking...

119+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

120+ - cd ${DISTDIR} || false

121+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;

122+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;

123+ - PKGDIR_servant_quickcheck="$(find . -maxdepth 1 -type d -regex '.*/servant-quickcheck-[0-9.]*')"

124+ # Generate cabal.project

125+ - rm -rf cabal.project cabal.project.local cabal.project.freeze

126+ - touch cabal.project

127+ - |

128+ echo "packages: ${PKGDIR_servant_quickcheck}" >> cabal.project

129+ - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi

130+ - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi"

131+ - |

132+ - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-quickcheck)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

133+ - cat cabal.project || true

134+ - cat cabal.project.local || true

135+ # Building...

136+ # this builds all libraries and executables (without tests/benchmarks)

137+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all

138+ # Building with tests and benchmarks...

139+ # build & run tests, build benchmarks

140+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all

141+ # Testing...

142+ - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all

143+ # cabal check...

144+ - (cd ${PKGDIR_servant_quickcheck} && ${CABAL} -vnormal check)

145+ # haddock...

146+ - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all

147+ # Building without installed constraints for packages in global-db...

148+ - rm -f cabal.project.local

149+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all

150+ # Constraint sets

151+ - rm -rf cabal.project.local

152+ # Constraint set base-compat-0.10

153+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.10.*' all

154+ # Constraint set base-compat-0.11

155+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.11.*' all

156

32−cache:

157+# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","servant-quickcheck.cabal"])

33− directories:

158+# EOF

34− - $HOME/.tinc/cache

CHANGELOG.yamlnew file+214

@@ -0,0 +1,214 @@

1+releases:

2+ - version: "0.0.9.0"

3+ changes:

4+ - description: "Support servant-0.15 (#65)"

5+ authors: fizruk

6+ date: 2020-06-25

8+ - description: "Relax constraints for GHC 8.10 (#70)"

9+ authors: felixmulder

10+ date: 2020-06-20

11+

12+ - version: "0.0.8.0"

13+ changes:

14+ - description: Support for servant-0.17

15+ authors: phadej

16+ date: 2019-01-23

17+

18+ - version: "0.0.7.3"

19+ changes:

20+ - description: Support for servant-0.14

21+ issue: 53

22+ authors: phadej

23+ date: 2018-06-12

24+

25+ - description: Fix a failure from OnlyJsonObjects when there is no content-type.

26+ issue: 55

27+ authors: Phenitei

28+ date: 2018-08-27

29+

30+ - description: A bug fix where notAllowedContainsAllowHeader would print the initial request alongside the failure instead of the request causing the failure when it failed.

31+ issue: 57

32+ authors: Phenitei

33+ date: 2018-08-29

34+

35+ - description: QuickCheck 2.12 compatibility

36+ issue: 58

37+ authors: parsonsmatt

38+ date: 2018-10-12

39+

40+ - description: GHC 8.6 compatibility

41+ issue: 59

42+ authors: phadej

43+ date: 2018-10-15

44+

45+ - version: "0.0.7.2"

46+ changes:

47+

48+ - description: Allow client to pass an HTTP Manager in to functions

49+ issue: 47

50+ authors: parsonsmatt

51+ date: 2018-05-10

52+

53+ - description: Fix "should not happen" error when exceptions are thrown

54+ issue: 48

55+ authors: parsonsmatt

56+ date: 2018-05-10

57+

58+ - version: "0.0.7.0"

59+ changes:

60+

61+ - description: Support for base-compat-0.10

62+ issue: none

63+ authors: phadej

64+ date: 2018-04-12

65+

66+ - version: "0.0.7.0"

67+ changes:

68+

69+ - description: Support for GHC-8.4.1

70+ issue: none

71+ authors: phadej

72+ date: 2018-03-23

73+

74+ - description: Requires hspec-2.5

75+ issue: none

76+ authors: phadej

77+ date: 2018-03-23

78+

79+ - version: "0.0.6.0"

80+ changes:

81+

82+ - description: Support for servant-0.12

83+ issue: none

84+ authors: phadej

85+ date: 2018-02-09

86+

87+ - version: "0.0.5.0"

88+ changes:

89+

90+ - description: Export forgotten predicates

91+ issue: none

92+ pr: 40

93+ authors: Phenitei

94+ date: 2017-12-14

95+

96+ - version: "0.0.4"

97+ changes:

98+

99+ - description: Support for Servant 0.12

100+ issue: none

101+ authors: phadej

102+ date: 2017-11-07

103+

104+ - description: Support for Servant 0.11

105+ issue: none

106+ pr: 32

107+ authors: adinapoli-iohk

108+ date: 2017-10-18

109+ notes: Includes 0-weighted instance for EmptyAPI

110+

111+ - version: "0.0.3.0"

112+ changes:

113+

114+ - description: Add jsonEquality

115+ issue: 2

116+ pr: 30

117+ authors: erewok

118+ date: 2017-10-15

119+

120+ - description: Support hspec >= 2.4

121+ issue: 27

122+ pr: 29

123+ authors: erewok, jkarni

124+ date: 2017-10-15

125+

126+ - version: "0.0.2.4"

127+ changes:

128+

129+ - description: Don't append slashes to paths

130+ issue: 22

131+ authors: declension

132+ date: 2017-03-11

133+

134+ - version: "0.0.2.3"

135+ changes:

136+

137+ - description: Fix QueryParam and QueryFlag requests

138+ issue: 23

139+ authors: declension

140+ date: 2017-03-10

141+

142+ - version: "0.0.2.2"

143+ changes:

144+

145+ - description: Make onlyJsonObjects succeed in non-JSON endpoints

146+ issue: 20

147+ authors: jkarni

148+ date: 2016-10-18

149+

150+

151+ - version: "0.0.2.1"

152+ changes:

153+

154+ - description: Add notLongerThan predicate

155+ pr: 17

156+ authors: jkarni

157+ date: 2016-10-05

158+

159+ - description: Add getsHaveLastModifiedHeader predicate

160+ pr: none

161+ authors: jkarni

162+ date: 2016-10-03

163+

164+ - description: Raise upper bounds

165+ notes: >

166+ For Quickcheck, aeson, http-client, servant, servant-client and

167+ servant-server.

168+ pr: none

169+ authors: jkarni

170+ date: 2016-10-03

171+

172+

173+ - version: "0.0.2.0"

174+ changes:

175+

176+ - description: Update CHANGELOG to YAML syntax.

177+ pr: 16

178+ authors: jkarni

179+ date: 2016-09-14

180+

181+ - description: Support new CaptureAll combinator

182+ pr: 16

183+ authors: jkarni

184+ date: 2016-09-14

185+

186+ - description: Support GHC 8

187+ pr: 16

188+ authors: jkarni

189+ date: 2016-09-14

190+

191+ - version: "0.0.1.1"

192+ changes:

193+

194+ - description: Exclude GHC 7.8 (by bumping base lower bound to 4.8)

195+ pr: none

196+ authors: jkarni

197+

198+ - description: More generous bounds for other packages.

199+ pr: none

200+ authors: jkarni

201+

202+ - version: "0.0.1.0"

203+ changes:

204+

205+ - description: Better error messages.

206+ notes: >

207+ Error messages now contain failing predicate, failing response and

208+ (except for response predicates), failing requests.

209+ pr: none

210+ authors: jkarni

211+

212+ - description: Signicant changes to RequestPredicate and ResponsePredicate types.

213+ pr: none

214+ authors: jkarni

cabal.haskell-cinew file+7

@@ -0,0 +1,7 @@

1+branches: master

3+constraint-set base-compat-0.10

4+ constraints: base-compat ==0.10.*

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

4+allow-newer: servant-blaze:servant

example/Main.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# LANGUAGE OverloadedStrings, DataKinds #-}

2+module Main (main) where

4+import Servant

5+import Servant.QuickCheck

6+import Test.Hspec

7+import Data.Text (Text)

8+import System.Environment (getArgs)

10+main :: IO ()

11+main = do

12+ args <- getArgs

13+ case args of

14+ [] -> putStrLn "Not running without arguments. Try --help or --fail-fast."

15+ _ -> hspec spec

16+

17+-- Change to String to reproduce

18+-- https://github.com/haskell-servant/servant-quickcheck/issues/41

19+type API = Get '[PlainText] Text

20+

21+api :: Proxy API

22+api = Proxy

23+

24+server :: Server API

25+server = return "Sigurð Fáfnirslayer"

26+

27+spec :: Spec

28+spec = describe "example server" $

29+ it "mangles UTF-8 in error messages" $

30+ withServantServer api (return server) $ \burl ->

31+ serverSatisfies api burl defaultArgs (getsHaveCacheControlHeader <%> mempty)

servant-quickcheck.cabal+126−88

@@ -1,100 +1,138 @@

1−name: servant-quickcheck

1+name: servant-quickcheck

2−version: 0.0.0.0

2+version: 0.0.9.1

3−synopsis: QuickCheck entire APIs

3+synopsis: QuickCheck entire APIs

4description:

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.

8−license: BSD3

8+license: BSD3

9−license-file: LICENSE

9+license-file: LICENSE

10−author: Julian K. Arni

10+author: Julian K. Arni

11−maintainer: jkarni@gmail.com

11+maintainer: jkarni@gmail.com

12−category: Web

12+category: Web

13−build-type: Simple

13+build-type: Simple

14−cabal-version: >=1.10

14+cabal-version: >=1.10

15+extra-source-files: CHANGELOG.yaml

16+tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3

17+

18+source-repository head

19+ type: git

20+ location: https://github.com/haskell-servant/servant-quickcheck

16flag long-tests

22flag long-tests

17 description: Run more QuickCheck tests

23 description: Run more QuickCheck tests

18 default: False

24 default: False

20library

26library

21− exposed-modules: Servant.QuickCheck

27+ exposed-modules:

22− , Servant.QuickCheck.Internal

28+ Servant.QuickCheck

23− , Servant.QuickCheck.Internal.Predicates

29+ Servant.QuickCheck.Internal

24− , Servant.QuickCheck.Internal.HasGenRequest

25− , Servant.QuickCheck.Internal.QuickCheck

26− , Servant.QuickCheck.Internal.Equality

30+ Servant.QuickCheck.Internal.Equality

27− , Servant.QuickCheck.Internal.ErrorTypes

31+ Servant.QuickCheck.Internal.ErrorTypes

32+ Servant.QuickCheck.Internal.HasGenRequest

33+ Servant.QuickCheck.Internal.Predicates

34+ Servant.QuickCheck.Internal.QuickCheck

35+

28− build-depends: base >=4.7 && <4.9

36+ build-depends:

37+ aeson >=0.8 && <2

38+ , base >=4.9 && <4.15

29− , base-compat == 0.9.*

39+ , base-compat-batteries >=0.10.1 && <0.12

30− , QuickCheck == 2.8.*

40+ , bytestring >=0.10 && <0.11

31− , bytestring == 0.10.*

41+ , case-insensitive >=1.2 && <1.3

32− , aeson > 0.10 && < 0.12

42+ , clock >=0.7 && <0.9

33− , mtl == 2.2.*

43+ , data-default-class >=0.0 && <0.2

34− , http-client == 0.4.*

44+ , hspec >=2.5.6 && <2.8

35− , http-types == 0.9.*

45+ , http-client >=0.4.30 && <0.8

36− , http-media == 0.6.*

46+ , http-media >=0.6 && <0.9

47+ , http-types >=0.8 && <0.13

48+ , mtl >=2.1 && <2.3

49+ , pretty >=1.1 && <1.2

50+ , process >=1.2 && <1.7

51+ , QuickCheck >=2.7 && <2.15

52+ , servant >=0.17 && <0.19

37− , servant-client == 0.7.*

53+ , servant-client >=0.17 && <0.19

38− , servant-server == 0.7.*

54+ , servant-server >=0.17 && <0.19

55+ , split >=0.2 && <0.3

39− , string-conversions == 0.4.*

56+ , string-conversions >=0.3 && <0.5

40− , data-default-class == 0.0.*

41− , servant == 0.7.*

42− , warp >= 3.2.4 && < 3.3

43− , process == 1.2.*

44− , temporary == 1.2.*

57+ , temporary >=1.2 && <1.4

45− , split == 0.2.*

46− , case-insensitive == 1.2.*

47− , hspec == 2.2.*

48− , text == 1.*

58+ , text >=1 && <2

49− , pretty == 1.1.*

59+ , time >=1.5 && <1.11

60+ , warp >=3.2.4 && <3.4

61+

50− if impl(ghc < 7.10)

62+ if !impl(ghc >=8.0)

51− build-depends: bifunctors == 5.*

63+ build-depends: semigroups >=0.18.3 && <0.20

64+

65+ hs-source-dirs: src

66+ default-extensions:

67+ NoImplicitPrelude

68+ ConstraintKinds

69+ DataKinds

70+ DeriveDataTypeable

71+ DeriveFunctor

72+ DeriveGeneric

73+ FlexibleContexts

74+ FlexibleInstances

75+ FunctionalDependencies

76+ GADTs

77+ KindSignatures

78+ MultiParamTypeClasses

79+ OverloadedStrings

80+ RankNTypes

81+ ScopedTypeVariables

82+ TypeOperators

53− hs-source-dirs: src

54− default-extensions: TypeOperators

55− , FlexibleInstances

56− , FlexibleContexts

57− , DataKinds

58− , GADTs

59− , MultiParamTypeClasses

60− , DeriveFunctor

61− , KindSignatures

62− , RankNTypes

63− , ConstraintKinds

64− , DeriveGeneric

65− , ScopedTypeVariables

66− , OverloadedStrings

67− , FunctionalDependencies

68− , NoImplicitPrelude

69− default-language: Haskell2010

84+ default-language: Haskell2010

71test-suite spec

86test-suite spec

72− type: exitcode-stdio-1.0

87+ type: exitcode-stdio-1.0

73− ghc-options: -Wall -threaded

88+ ghc-options: -Wall -threaded

74− default-language: Haskell2010

89+ default-language: Haskell2010

75− hs-source-dirs: test

90+ hs-source-dirs: test

76− main-is: Spec.hs

91+ main-is: Spec.hs

77− other-modules: Servant.QuickCheck.InternalSpec

92+ other-modules: Servant.QuickCheck.InternalSpec

78− build-depends: base == 4.*

93+ build-tool-depends: hspec-discover:hspec-discover -any

94+ build-depends:

95+ aeson

96+ , base

79− , base-compat

97+ , base-compat-batteries

80− , servant-quickcheck

98+ , blaze-html

99+ , bytestring

81− , hspec

100+ , hspec

82− , hspec-core

101+ , hspec-core >=2.5.5 && <2.8

83− , http-client

102+ , http-client

84− , warp

103+ , QuickCheck

104+ , quickcheck-io

105+ , servant

106+ , servant-blaze

107+ , servant-client

108+ , servant-quickcheck

85− , servant-server

109+ , servant-server

86− , servant-client

87− , servant

88− , transformers

110+ , transformers

89− , QuickCheck

111+ , warp

90− , quickcheck-io

112+

91− default-extensions: TypeOperators

113+ default-extensions:

92− , FlexibleInstances

114+ NoImplicitPrelude

115+ DataKinds

93− , FlexibleContexts

116+ FlexibleContexts

117+ FlexibleInstances

94− , GADTs

118+ GADTs

95− , DataKinds

96− , NoImplicitPrelude

97− , OverloadedStrings

119+ OverloadedStrings

98− , ScopedTypeVariables

120+ ScopedTypeVariables

121+ TypeOperators

122+

99 if flag(long-tests)

123 if flag(long-tests)

100− cpp-options: -DLONG_TESTS

124+ cpp-options: -DLONG_TESTS

125+

126+test-suite example

127+ type: exitcode-stdio-1.0

128+ main-is: Main.hs

129+ hs-source-dirs: example

130+ ghc-options: -Wall

131+ build-depends:

132+ base

133+ , hspec

134+ , servant-quickcheck

135+ , servant-server

136+ , text

137+

138+ default-language: Haskell2010

src/Servant/QuickCheck.hs+10−3

@@ -27,12 +27,18 @@ module Servant.QuickCheck

27 -- in RFCs. The __Best Practices__ includes, in addition to RFC

28 -- recommendations, recommendations found elsewhere or generally accepted.

29 , not500

30+ , notLongerThan

30 , onlyJsonObjects

31 , onlyJsonObjects

32+ , honoursAcceptHeader

31 , notAllowedContainsAllowHeader

33 , notAllowedContainsAllowHeader

32 , unauthorizedContainsWWWAuthenticate

34 , unauthorizedContainsWWWAuthenticate

35+ , getsHaveLastModifiedHeader

33 , getsHaveCacheControlHeader

36 , getsHaveCacheControlHeader

34 , headsHaveCacheControlHeader

37 , headsHaveCacheControlHeader

35 , createContainsValidLocation

38 , createContainsValidLocation

39+ -- * Html Predicates

40+ , htmlIncludesDoctype

41+

36 -- *** Predicate utilities and types

42 -- *** Predicate utilities and types

37 , (<%>)

43 , (<%>)

38 , Predicates

44 , Predicates

@@ -48,6 +54,7 @@ module Servant.QuickCheck

48 -- represents other means of checking equality

54 -- represents other means of checking equality

49 -- *** Useful @ResponseEquality@s

55 -- *** Useful @ResponseEquality@s

50 , bodyEquality

56 , bodyEquality

57+ , jsonEquality

51 , allEquality

58 , allEquality

52 -- ** Response equality type

59 -- ** Response equality type

53 , ResponseEquality(..)

60 , ResponseEquality(..)

@@ -69,10 +76,10 @@ module Servant.QuickCheck

70 ) where

77 ) where

79+import Data.Proxy (Proxy (..))

80+import Servant.Client (BaseUrl (..), Scheme (..))

72import Servant.QuickCheck.Internal

81import Servant.QuickCheck.Internal

73−import Servant.Client (BaseUrl(..), Scheme(..))

74−import Test.QuickCheck (Args(..), stdArgs)

82+import Test.QuickCheck (Args (..), stdArgs)

75−import Data.Proxy (Proxy(..))

77-- | QuickCheck @Args@ with 1000 rather than 100 test cases.

84-- | QuickCheck @Args@ with 1000 rather than 100 test cases.

78--

85--

src/Servant/QuickCheck/Internal.hs+4−4

@@ -1,7 +1,7 @@

1module Servant.QuickCheck.Internal (module X) where

3+import Servant.QuickCheck.Internal.Equality as X

4+import Servant.QuickCheck.Internal.ErrorTypes as X

3import Servant.QuickCheck.Internal.HasGenRequest as X

5import Servant.QuickCheck.Internal.HasGenRequest as X

4−import Servant.QuickCheck.Internal.Predicates as X

6+import Servant.QuickCheck.Internal.Predicates as X

5−import Servant.QuickCheck.Internal.QuickCheck as X

7+import Servant.QuickCheck.Internal.QuickCheck as X

6−import Servant.QuickCheck.Internal.Equality as X

7−import Servant.QuickCheck.Internal.ErrorTypes as X

src/Servant/QuickCheck/Internal/Equality.hs+38−5

@@ -1,16 +1,23 @@

1module Servant.QuickCheck.Internal.Equality where

3+import Data.Aeson (Value, decode, decodeStrict)

4+import Data.ByteString (ByteString)

5+import qualified Data.ByteString.Lazy as LB

3−import Data.Function (on)

6+import Data.Function (on)

4−import Network.HTTP.Client (Response, responseBody)

7+import Network.HTTP.Client (Response, responseBody)

8+import Data.Semigroup (Semigroup (..))

5−import Prelude.Compat

9+import Prelude.Compat

7newtype ResponseEquality b

11newtype ResponseEquality b

8 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }

12 = ResponseEquality { getResponseEquality :: Response b -> Response b -> Bool }

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

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+26−16

@@ -1,15 +1,40 @@

1+{-# LANGUAGE CPP #-}

1module Servant.QuickCheck.Internal.ErrorTypes where

2module Servant.QuickCheck.Internal.ErrorTypes where

3import Control.Exception (Exception (..))

4import Control.Exception (Exception (..))

4import qualified Data.ByteString.Lazy as LBS

5import qualified Data.ByteString.Lazy as LBS

5import Data.String.Conversions (cs)

6import Data.String.Conversions (cs)

6import qualified Data.Text as T

7import qualified Data.Text as T

8+import Data.Typeable (Typeable)

7import GHC.Generics (Generic)

9import GHC.Generics (Generic)

8import qualified Network.HTTP.Client as C

10import qualified Network.HTTP.Client as C

9import Network.HTTP.Types (Header, statusCode)

11import Network.HTTP.Types (Header, statusCode)

10−import Prelude.Compat

11import Text.PrettyPrint

12import Text.PrettyPrint

14+import Prelude.Compat hiding ((<>))

15+

16+data PredicateFailure

17+ = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)

18+ deriving (Typeable, Generic)

19+

20+instance Exception ServerEqualityFailure where

21+

22+instance Show PredicateFailure where

23+ show = render . prettyPredicateFailure

24+

25+

26+data ServerEqualityFailure

27+ = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)

28+ deriving (Typeable, Generic)

29+

30+instance Show ServerEqualityFailure where

31+ show = render . prettyServerEqualityFailure

32+

33+

34+instance Exception PredicateFailure where

35+

36+-- * Pretty printing

37+

13prettyHeaders :: [Header] -> Doc

38prettyHeaders :: [Header] -> Doc

14prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs

39prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs

15 where

40 where

@@ -35,12 +60,6 @@ prettyResp r =

35 $$ text "Body:" <+> (nest 5 $ text . cs $ C.responseBody r))

60 $$ text "Body:" <+> (nest 5 $ text . cs $ C.responseBody r))

38−-- The error that occurred.

39−data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)

40− deriving (Generic)

41−

42−data ServerEqualityFailure = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)

43− deriving (Generic)

45prettyServerEqualityFailure :: ServerEqualityFailure -> Doc

64prettyServerEqualityFailure :: ServerEqualityFailure -> Doc

46prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =

65prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =

@@ -61,12 +80,3 @@ prettyPredicateFailure (PredicateFailure predicate req resp) =

61 Nothing -> text ""

80 Nothing -> text ""

62 Just v -> prettyReq v

81 Just v -> prettyReq v

64−instance Show ServerEqualityFailure where

65− show = render . prettyServerEqualityFailure

66−

67−instance Exception ServerEqualityFailure where

68−

69−instance Show PredicateFailure where

70− show = render . prettyPredicateFailure

71−

72−instance Exception PredicateFailure where

src/Servant/QuickCheck/Internal/HasGenRequest.hs+113−53

@@ -1,98 +1,148 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE PolyKinds #-}

2{-# LANGUAGE PolyKinds #-}

2module Servant.QuickCheck.Internal.HasGenRequest where

3module Servant.QuickCheck.Internal.HasGenRequest where

4−import Data.Default.Class (def)

5−import Data.Monoid ((<>))

6−import Data.String (fromString)

5+import Data.String (fromString)

7−import Data.String.Conversions (cs)

6+import Data.String.Conversions (cs)

8−import GHC.TypeLits (KnownSymbol, Nat, symbolVal)

7+import GHC.TypeLits (KnownSymbol, Nat, symbolVal)

9−import Network.HTTP.Client (Request, RequestBody (..), host,

8+import Network.HTTP.Client (Request, RequestBody (..), host, method, path,

10− method, path, port, queryString,

11− requestBody, requestHeaders, secure)

9+ port, queryString, requestBody, requestHeaders,

10+ secure, defaultRequest)

12−import Network.HTTP.Media (renderHeader)

11+import Network.HTTP.Media (renderHeader)

13−import Prelude.Compat

12+import Prelude.Compat

14−import Servant

13+import Servant

15−import Servant.API.ContentTypes (AllMimeRender (..))

14+import Servant.API.ContentTypes (AllMimeRender (..))

16−import Servant.Client (BaseUrl (..), Scheme (..))

15+import Servant.Client (BaseUrl (..), Scheme (..))

17−import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)

16+import Test.QuickCheck (Arbitrary (..), Gen, elements, frequency)

18−

17+

19−

18+import qualified Data.ByteString as BS

19+import qualified Data.ByteString.Internal as BS (c2w)

20+

21+

22+-- -----------------------------------------------------------------------------

23+-- runGenRequest

24+

25+-- | This function returns a QuickCheck `Gen a` when passed a servant API value,

26+-- typically a `Proxy API`. The generator returned is a function

27+-- that accepts a `BaseUrl` and returns a `Request`, which can then be used

28+-- to issue network requests. This `Gen` type makes it easier to compare distinct

29+-- APIs across different `BaseUrl`s.

30+runGenRequest :: HasGenRequest a => Proxy a -> Gen (BaseUrl -> Request)

31+runGenRequest = snd . genRequest

32+

33+

34+-- -----------------------------------------------------------------------------

35+-- HasGenRequest

36+

37+-- | This is the core Servant-Quickcheck generator, which, when given a `Proxy API`

38+-- will return a pair of `Int` and `Gen a`, where `a` is a function from

39+-- `BaseUrl` to a `Network.Http.Client.Request`. The `Int` is a weight for the

40+-- QuickCheck `frequency` function which ensures a random distribution across

41+-- all endpoints in an API.

20class HasGenRequest a where

42class HasGenRequest a where

21− genRequest :: Proxy a -> Gen (BaseUrl -> Request)

43+ genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))

44+

23instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where

46instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where

24 genRequest _

47 genRequest _

48+ = (lf + rf, frequency [l, r])

49+ where

25− = oneof [ genRequest (Proxy :: Proxy a)

50+ l@(lf, _) = genRequest (Proxy :: Proxy a)

26− , genRequest (Proxy :: Proxy b)

51+ r@(rf, _) = genRequest (Proxy :: Proxy b)

27− ]

52+

29instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where

54instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where

30− genRequest _ = do

55+ genRequest _ = (oldf, do

31 old' <- old

56 old' <- old

32− return $ \burl -> let r = old' burl in r { path = new <> path r }

57+ return $ \burl -> let r = old' burl

58+ oldPath = path r

59+ oldPath' = BS.dropWhile (== BS.c2w '/') oldPath

60+ paths = filter (not . BS.null) [new, oldPath']

61+ in r { path = "/" <> BS.intercalate "/" paths })

33 where

62 where

34− old = genRequest (Proxy :: Proxy b)

63+ (oldf, old) = genRequest (Proxy :: Proxy b)

35 new = cs $ symbolVal (Proxy :: Proxy path)

64 new = cs $ symbolVal (Proxy :: Proxy path)

66+instance HasGenRequest EmptyAPI where

67+ genRequest _ = (0, error "EmptyAPIs cannot be queried.")

68+

69+instance HasGenRequest api => HasGenRequest (Summary d :> api) where

70+ genRequest _ = genRequest (Proxy :: Proxy api)

71+

72+instance HasGenRequest api => HasGenRequest (Description d :> api) where

73+ genRequest _ = genRequest (Proxy :: Proxy api)

74+

37instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )

75instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )

38− => HasGenRequest (Capture x c :> b) where

76+ => HasGenRequest (Capture' mods x c :> b) where

39− genRequest _ = do

77+ genRequest _ = (oldf, do

40 old' <- old

78 old' <- old

41 new' <- toUrlPiece <$> new

79 new' <- toUrlPiece <$> new

42− return $ \burl -> let r = old' burl in r { path = cs new' <> path r }

80+ return $ \burl -> let r = old' burl in r { path = cs new' <> path r })

43 where

81 where

44− old = genRequest (Proxy :: Proxy b)

82+ (oldf, old) = genRequest (Proxy :: Proxy b)

45 new = arbitrary :: Gen c

83 new = arbitrary :: Gen c

85+instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )

86+ => HasGenRequest (CaptureAll x c :> b) where

87+ genRequest _ = (oldf, do

88+ old' <- old

89+ new' <- fmap (cs . toUrlPiece) <$> new

90+ let new'' = BS.intercalate "/" new'

91+ return $ \burl -> let r = old' burl in r { path = new'' <> path r })

92+ where

93+ (oldf, old) = genRequest (Proxy :: Proxy b)

94+ new = arbitrary :: Gen [c]

95+

47instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)

96instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)

48− => HasGenRequest (Header h c :> b) where

97+ => HasGenRequest (Header' mods h c :> b) where

49− genRequest _ = do

98+ genRequest _ = (oldf, do

50 old' <- old

99 old' <- old

51− new' <- toUrlPiece <$> new

100+ new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional

52 return $ \burl -> let r = old' burl in r {

101 return $ \burl -> let r = old' burl in r {

53− requestHeaders = (hdr, cs new') : requestHeaders r }

102+ requestHeaders = (hdr, cs new') : requestHeaders r })

54 where

103 where

55− old = genRequest (Proxy :: Proxy b)

104+ (oldf, old) = genRequest (Proxy :: Proxy b)

56 hdr = fromString $ symbolVal (Proxy :: Proxy h)

105 hdr = fromString $ symbolVal (Proxy :: Proxy h)

57 new = arbitrary :: Gen c

106 new = arbitrary :: Gen c

107

59instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)

108instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)

60− => HasGenRequest (ReqBody x c :> b) where

109+ => HasGenRequest (ReqBody' mods x c :> b) where

61− genRequest _ = do

110+ genRequest _ = (oldf, do

62− old' <- old

111+ old' <- old -- TODO: generate lenient

63 new' <- new

112 new' <- new

64 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'

113 (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'

65 return $ \burl -> let r = old' burl in r {

114 return $ \burl -> let r = old' burl in r {

66 requestBody = RequestBodyLBS bd

115 requestBody = RequestBodyLBS bd

67 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r

116 , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r

68− }

117+ })

69 where

118 where

70− old = genRequest (Proxy :: Proxy b)

119+ (oldf, old) = genRequest (Proxy :: Proxy b)

71 new = arbitrary :: Gen c

120 new = arbitrary :: Gen c

121

73instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)

122instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)

74− => HasGenRequest (QueryParam x c :> b) where

123+ => HasGenRequest (QueryParam' mods x c :> b) where

75− genRequest _ = do

124+ genRequest _ = (oldf, do

76− new' <- new

125+ new' <- new -- TODO: generate lenient or/and optional

77 old' <- old

126 old' <- old

78− return $ \burl -> let r = old' burl in r {

127+ return $ \burl -> let r = old' burl

79− queryString = queryString r

80− <> param <> "=" <> cs (toQueryParam new') }

128+ newExpr = param <> "=" <> cs (toQueryParam new')

129+ qs = queryString r in r {

130+ queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })

81 where

131 where

82− old = genRequest (Proxy :: Proxy b)

132+ (oldf, old) = genRequest (Proxy :: Proxy b)

83 param = cs $ symbolVal (Proxy :: Proxy x)

133 param = cs $ symbolVal (Proxy :: Proxy x)

84 new = arbitrary :: Gen c

134 new = arbitrary :: Gen c

135

86instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)

136instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)

87 => HasGenRequest (QueryParams x c :> b) where

137 => HasGenRequest (QueryParams x c :> b) where

88− genRequest _ = do

138+ genRequest _ = (oldf, do

89 new' <- new

139 new' <- new

90 old' <- old

140 old' <- old

91 return $ \burl -> let r = old' burl in r {

141 return $ \burl -> let r = old' burl in r {

92 queryString = queryString r

142 queryString = queryString r

93− <> if length new' > 0 then fold (toParam <$> new') else ""}

143+ <> if length new' > 0 then fold (toParam <$> new') else ""})

94 where

144 where

95− old = genRequest (Proxy :: Proxy b)

145+ (oldf, old) = genRequest (Proxy :: Proxy b)

96 param = cs $ symbolVal (Proxy :: Proxy x)

146 param = cs $ symbolVal (Proxy :: Proxy x)

97 new = arbitrary :: Gen [c]

147 new = arbitrary :: Gen [c]

98 toParam c = param <> "[]=" <> cs (toQueryParam c)

148 toParam c = param <> "[]=" <> cs (toQueryParam c)

@@ -100,22 +150,32 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)

100

150

101instance (KnownSymbol x, HasGenRequest b)

151instance (KnownSymbol x, HasGenRequest b)

102 => HasGenRequest (QueryFlag x :> b) where

152 => HasGenRequest (QueryFlag x :> b) where

103− genRequest _ = do

153+ genRequest _ = (oldf, do

104 old' <- old

154 old' <- old

105− return $ \burl -> let r = old' burl in r {

155+ return $ \burl -> let r = old' burl

156+ qs = queryString r in r {

106− queryString = queryString r <> param <> "=" }

157+ queryString = if BS.null qs then param else param <> "&" <> qs })

107 where

158 where

108− old = genRequest (Proxy :: Proxy b)

159+ (oldf, old) = genRequest (Proxy :: Proxy b)

109 param = cs $ symbolVal (Proxy :: Proxy x)

160 param = cs $ symbolVal (Proxy :: Proxy x)

110

161

111instance (ReflectMethod method)

162instance (ReflectMethod method)

112 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where

163 => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where

113− genRequest _ = return $ \burl -> def

164+ genRequest _ = (1, return $ \burl -> defaultRequest

165+ { host = cs $ baseUrlHost burl

166+ , port = baseUrlPort burl

167+ , secure = baseUrlScheme burl == Https

168+ , method = reflectMethod (Proxy :: Proxy method)

169+ })

170+

171+instance (ReflectMethod method)

172+ => HasGenRequest (NoContentVerb (method :: k)) where

173+ genRequest _ = (1, return $ \burl -> defaultRequest

114 { host = cs $ baseUrlHost burl

174 { host = cs $ baseUrlHost burl

115 , port = baseUrlPort burl

175 , port = baseUrlPort burl

116 , secure = baseUrlScheme burl == Https

176 , secure = baseUrlScheme burl == Https

117 , method = reflectMethod (Proxy :: Proxy method)

177 , method = reflectMethod (Proxy :: Proxy method)

118− }

178+ })

119

179

120instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where

180instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where

121 genRequest _ = genRequest (Proxy :: Proxy a)

181 genRequest _ = genRequest (Proxy :: Proxy a)

src/Servant/QuickCheck/Internal/Predicates.hs+140−44

@@ -1,30 +1,33 @@

1module Servant.QuickCheck.Internal.Predicates where

3−import Control.Exception (catch, SomeException, throw)

3+import Control.Exception (catch, throw)

4−import Control.Monad (liftM2, guard, ap)

4+import Control.Monad (liftM2, unless, when)

5−import Control.Monad.Reader

6import Data.Aeson (Object, decode)

5import Data.Aeson (Object, decode)

7−import Data.Bifunctor (Bifunctor (..))

6+import Data.Bifunctor (first)

8−import Prelude.Compat

9import qualified Data.ByteString as SBS

7import qualified Data.ByteString as SBS

10import qualified Data.ByteString.Char8 as SBSC

8import qualified Data.ByteString.Char8 as SBSC

11import qualified Data.ByteString.Lazy as LBS

9import qualified Data.ByteString.Lazy as LBS

12−import Data.CaseInsensitive (mk)

10+import Data.CaseInsensitive (foldCase, foldedCase, mk)

13import Data.Either (isRight)

11import Data.Either (isRight)

14import Data.List.Split (wordsBy)

12import Data.List.Split (wordsBy)

15import Data.Maybe (fromMaybe, isJust)

13import Data.Maybe (fromMaybe, isJust)

16−import Data.Monoid ((<>))

14+import Data.Semigroup (Semigroup (..))

17−import Data.Text (Text)

15+import qualified Data.Text as T

16+import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,

17+ rfc822DateFormat)

18import GHC.Generics (Generic)

19import Network.HTTP.Client (Manager, Request, Response, httpLbs,

20− method, parseUrl, requestHeaders,

20+ method, parseRequest, requestHeaders,

21 responseBody, responseHeaders,

22 responseStatus)

23import Network.HTTP.Media (matchAccept)

24import Network.HTTP.Types (methodGet, methodHead, parseMethod,

25− renderStdMethod, status200, status201,

25+ renderStdMethod, status100, status200,

26− status300, status401, status405,

26+ status201, status300, status401,

27− status500, status100)

27+ status405, status500)

28+import Prelude.Compat

29+import System.Clock (Clock (Monotonic), diffTimeSpec,

30+ getTime, toNanoSecs)

29import Servant.QuickCheck.Internal.ErrorTypes

32import Servant.QuickCheck.Internal.ErrorTypes

@@ -40,7 +43,23 @@ import Servant.QuickCheck.Internal.ErrorTypes

40-- /Since 0.0.0.0/

43-- /Since 0.0.0.0/

41not500 :: ResponsePredicate

44not500 :: ResponsePredicate

42not500 = ResponsePredicate $ \resp ->

45not500 = ResponsePredicate $ \resp ->

43− when (responseStatus resp == status500) $ fail "not500"

46+ when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp

47+

48+-- | [__Optional__]

49+--

50+-- This function checks that the response from the server does not take longer

51+-- than the specified number of nanoseconds.

52+--

53+-- /Since 0.0.2.1/

54+notLongerThan :: Integer -> RequestPredicate

55+notLongerThan maxAllowed

56+ = RequestPredicate $ \req mgr -> do

57+ start <- getTime Monotonic

58+ resp <- httpLbs req mgr

59+ end <- getTime Monotonic

60+ when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $

61+ throw $ PredicateFailure "notLongerThan" (Just req) resp

62+ return []

45-- | [__Best Practice__]

64-- | [__Best Practice__]

46--

65--

@@ -65,9 +84,13 @@ not500 = ResponsePredicate $ \resp ->

65-- /Since 0.0.0.0/

84-- /Since 0.0.0.0/

66onlyJsonObjects :: ResponsePredicate

85onlyJsonObjects :: ResponsePredicate

67onlyJsonObjects

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

68− = ResponsePredicate (\resp -> case decode (responseBody resp) of

91+ case (decode (responseBody resp) :: Maybe Object) of

69− Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp

92+ Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp

70− Just (_ :: Object) -> return ())

93+ Just _ -> return ())

72-- | __Optional__

95-- | __Optional__

73--

96--

@@ -95,21 +118,52 @@ createContainsValidLocation

95 resp <- httpLbs req mgr

118 resp <- httpLbs req mgr

96 if responseStatus resp == status201

119 if responseStatus resp == status201

97 then case lookup "Location" $ responseHeaders resp of

120 then case lookup "Location" $ responseHeaders resp of

98− Nothing -> fail n

121+ Nothing -> throw $ PredicateFailure n (Just req) resp

99− Just l -> case parseUrl $ SBSC.unpack l of

122+ Just l -> case parseRequest $ SBSC.unpack l of

100− Nothing -> fail n

123+ Nothing -> throw $ PredicateFailure n (Just req) resp

101 Just x -> do

124 Just x -> do

102 resp2 <- httpLbs x mgr

125 resp2 <- httpLbs x mgr

103− status2XX resp2 n

126+ status2XX (Just req) resp2 n

104 return [resp, resp2]

127 return [resp, resp2]

105 else return [resp]

128 else return [resp]

106

129

107−{-

130+-- | [__Optional__]

131+--

132+-- The @Last-Modified@ header represents the time a resource was last

133+-- modified. It is used to drive caching and conditional requests.

134+--

135+-- When using this mechanism, the server adds the @Last-Modified@ header to

136+-- responses. Clients may then make requests with the @If-Modified-Since@

137+-- header to conditionally request resources. If the resource has not

138+-- changed since that date, the server responds with a status code of 304

139+-- (@Not Modified@) without a response body.

140+--

141+-- The @Last-Modified@ header can also be used in conjunction with the

142+-- @If-Unmodified-Since@ header to drive optimistic concurrency.

143+--

144+-- The @Last-Modified@ date must be in RFC 822 format.

145+--

146+-- __References__:

147+--

148+-- * 304 Not Modified: <https://tools.ietf.org/html/rfc7232#section-4.1 RFC 7232 Section 4.1>

149+-- * Last-Modified header: <https://tools.ietf.org/html/rfc7232#section-2.2 RFC 7232 Section 2.2>

150+-- * If-Modified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.3 RFC 7232 Section 3.3>

151+-- * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>

152+-- * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>

153+--

154+-- /Since 0.0.2.1/

108−getsHaveLastModifiedHeader :: ResponsePredicate

155+getsHaveLastModifiedHeader :: RequestPredicate

109getsHaveLastModifiedHeader

156getsHaveLastModifiedHeader

110− = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->

157+ = RequestPredicate $ \req mgr ->

158+ if (method req == methodGet)

159+ then do

160+ resp <- httpLbs req mgr

161+ unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do

162+ throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp

163+ return [resp]

164+ else return []

165+

111

166

112−-}

113

167

114-- | [__RFC Compliance__]

168-- | [__RFC Compliance__]

115--

169--

@@ -121,23 +175,27 @@ getsHaveLastModifiedHeader

121-- This function checks that every @405 Method Not Allowed@ response contains

175-- This function checks that every @405 Method Not Allowed@ response contains

122-- an @Allow@ header with a list of standard HTTP methods.

176-- an @Allow@ header with a list of standard HTTP methods.

123--

177--

178+-- Note that 'servant' itself does not currently set the @Allow@ headers.

179+--

124-- __References__:

180-- __References__:

125--

181--

126-- * @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>

127-- * 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>

128--

185--

129-- /Since 0.0.0.0/

186-- /Since 0.0.0.0/

130notAllowedContainsAllowHeader :: RequestPredicate

187notAllowedContainsAllowHeader :: RequestPredicate

131notAllowedContainsAllowHeader

188notAllowedContainsAllowHeader

132 = RequestPredicate $ \req mgr -> do

189 = RequestPredicate $ \req mgr -> do

133− resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }

190+ let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]

134− | m <- [minBound .. maxBound ]

135− , renderStdMethod m /= method req ]

191+ , renderStdMethod m /= method req ]

192+ resp <- mapM (flip httpLbs mgr) reqs

193+

136− case filter pred' resp of

194+ case filter pred' (zip reqs resp) of

137− (x:xs) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x

195+ (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)

138 [] -> return resp

196 [] -> return resp

139 where

197 where

140− pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)

198+ pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)

141 where

199 where

142 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)

200 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)

143 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)

201 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)

@@ -167,7 +225,7 @@ honoursAcceptHeader

167 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)

225 sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)

168 if status100 < scode && scode < status300

226 if status100 < scode && scode < status300

169 then if isJust $ sctype >>= \x -> matchAccept [x] sacc

227 then if isJust $ sctype >>= \x -> matchAccept [x] sacc

170− then fail "honoursAcceptHeader"

228+ then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp

171 else return [resp]

229 else return [resp]

172 else return [resp]

230 else return [resp]

173

231

@@ -278,7 +336,29 @@ unauthorizedContainsWWWAuthenticate

278 = ResponsePredicate $ \resp ->

336 = ResponsePredicate $ \resp ->

279 if responseStatus resp == status401

337 if responseStatus resp == status401

280 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $

338 then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $

281− 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

282 else return ()

362 else return ()

283

363

284-- * Predicate logic

364-- * Predicate logic

@@ -292,37 +372,47 @@ unauthorizedContainsWWWAuthenticate

292-- | A predicate that depends only on the response.

372-- | A predicate that depends only on the response.

293--

373--

294-- /Since 0.0.0.0/

374-- /Since 0.0.0.0/

295−data ResponsePredicate = ResponsePredicate

375+newtype ResponsePredicate = ResponsePredicate

296 { getResponsePredicate :: Response LBS.ByteString -> IO ()

376 { getResponsePredicate :: Response LBS.ByteString -> IO ()

297 } deriving (Generic)

377 } deriving (Generic)

298

378

379+instance Semigroup ResponsePredicate where

380+ ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x

381+

299instance Monoid ResponsePredicate where

382instance Monoid ResponsePredicate where

300 mempty = ResponsePredicate $ const $ return ()

383 mempty = ResponsePredicate $ const $ return ()

301− ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x

384+ mappend = (<>)

302

385

303-- | A predicate that depends on both the request and the response.

386-- | A predicate that depends on both the request and the response.

304--

387--

305-- /Since 0.0.0.0/

388-- /Since 0.0.0.0/

306−data RequestPredicate = RequestPredicate

389+newtype RequestPredicate = RequestPredicate

307− { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]

390+ { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]

308 } deriving (Generic)

391 } deriving (Generic)

309

392

310-- TODO: This isn't actually a monoid

393-- TODO: This isn't actually a monoid

311instance Monoid RequestPredicate where

394instance Monoid RequestPredicate where

312 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

313− RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->

400+ RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->

314 liftM2 (<>) (a r mgr) (b r mgr)

401 liftM2 (<>) (a r mgr) (b r mgr)

315

402

316-- | A set of predicates. Construct one with 'mempty' and '<%>'.

403-- | A set of predicates. Construct one with 'mempty' and '<%>'.

317data Predicates = Predicates

404data Predicates = Predicates

318− { requestPredicates :: RequestPredicate

405+ { requestPredicates :: RequestPredicate

319 , responsePredicates :: ResponsePredicate

406 , responsePredicates :: ResponsePredicate

320 } deriving (Generic)

407 } deriving (Generic)

321

408

409+instance Semigroup Predicates where

410+ a <> b = Predicates (requestPredicates a <> requestPredicates b)

411+ (responsePredicates a <> responsePredicates b)

412+

322instance Monoid Predicates where

413instance Monoid Predicates where

323 mempty = Predicates mempty mempty

414 mempty = Predicates mempty mempty

324− a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)

415+ mappend = (<>)

325− (responsePredicates a <> responsePredicates b)

326

416

327class JoinPreds a where

417class JoinPreds a where

328 joinPreds :: a -> Predicates -> Predicates

418 joinPreds :: a -> Predicates -> Predicates

@@ -358,8 +448,14 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of

358 Nothing -> False

448 Nothing -> False

359 Just v -> p v

449 Just v -> p v

360

450

451+isRFC822Date :: SBS.ByteString -> Bool

452+isRFC822Date s

453+ = case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of

454+ Nothing -> False

455+ Just (_ :: UTCTime) -> True

456+

361−status2XX :: Monad m => Response b -> String -> m ()

457+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()

362−status2XX r t

458+status2XX mreq resp t

363− | status200 <= responseStatus r && responseStatus r < status300

459+ | status200 <= responseStatus resp && responseStatus resp < status300

364 = return ()

460 = return ()

365− | otherwise = fail t

461+ | otherwise = throw $ PredicateFailure t mreq resp

src/Servant/QuickCheck/Internal/QuickCheck.hs+84−33

@@ -1,30 +1,31 @@

1{-# LANGUAGE RecordWildCards #-}

2+{-# LANGUAGE CPP #-}

2module Servant.QuickCheck.Internal.QuickCheck where

3module Servant.QuickCheck.Internal.QuickCheck where

5+import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)

6+import Control.Monad (unless)

4import qualified Data.ByteString.Lazy as LBS

7import qualified Data.ByteString.Lazy as LBS

5import Data.Proxy (Proxy)

8import Data.Proxy (Proxy)

6−import Data.String (IsString (..))

7−import Data.Text (Text)

8−import GHC.Generics (Generic)

9import qualified Network.HTTP.Client as C

10import Network.Wai.Handler.Warp (withApplication)

11import Prelude.Compat

12import Servant (Context (EmptyContext), HasServer,

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)

19−import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, run, monitor)

21+import Test.QuickCheck.Monadic (assert, forAllM, monadicIO, monitor,

22+ run)

20import Test.QuickCheck.Property (counterexample)

23import Test.QuickCheck.Property (counterexample)

21−import Control.Monad (unless)

22−import Control.Concurrent (newMVar, modifyMVar_, readMVar)

24import Servant.QuickCheck.Internal.Equality

25import Servant.QuickCheck.Internal.Equality

26+import Servant.QuickCheck.Internal.ErrorTypes

25import Servant.QuickCheck.Internal.HasGenRequest

27import Servant.QuickCheck.Internal.HasGenRequest

26import Servant.QuickCheck.Internal.Predicates

28import Servant.QuickCheck.Internal.Predicates

27−import Servant.QuickCheck.Internal.ErrorTypes

30-- | Start a servant application on an open port, run the provided function,

31-- | Start a servant application on an open port, run the provided function,

@@ -39,7 +40,11 @@ withServantServer api = withServantServerAndContext api EmptyContext

39-- application.

40-- application.

40--

41--

41-- /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

42withServantServerAndContext :: HasServer a ctx

46withServantServerAndContext :: HasServer a ctx

47+#endif

43 => 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

44withServantServerAndContext api ctx server t

49withServantServerAndContext api ctx server t

45 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->

50 = withApplication (return . serveWithContext api ctx =<< server) $ \port ->

@@ -57,29 +62,47 @@ withServantServerAndContext api ctx server t

57-- Evidently, if the behaviour of the server is expected to be

62-- Evidently, if the behaviour of the server is expected to be

58-- non-deterministic, this function may produce spurious failures

63-- non-deterministic, this function may produce spurious failures

59--

64--

65+-- Note that only valid requests are generated and tested. As an example of why

66+-- this matters, let's say your API specifies that a particular endpoint can

67+-- only generate @JSON@. @serversEqual@ will then not generate any requests

68+-- with an @Accept@ header _other_ than @application/json@. It may therefore

69+-- fail to notice that one application, when the request has @Accept:

70+-- text/html@, returns a @406 Not Acceptable@ HTTP response, and another

71+-- returns a @200 Success@, but with @application/json@ as the content-type.

72+--

73+-- The fact that only valid requests are tested also means that no endpoints

74+-- not listed in the API type are tested.

75+--

60-- /Since 0.0.0.0/

76-- /Since 0.0.0.0/

61serversEqual :: HasGenRequest a =>

77serversEqual :: HasGenRequest a =>

62 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation

78 Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation

63serversEqual api burl1 burl2 args req = do

79serversEqual api burl1 burl2 args req = do

64− let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api

80+ let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api

65 -- 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

66 -- return results when a test fails, since an exception is throw.

82 -- return results when a test fails, since an exception is throw.

67− deetsMVar <- newMVar $ error "should not be called"

83+ deetsMVar <- newEmptyMVar

68 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do

84 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do

69 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager

85 resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager

70 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager

86 resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager

71 unless (getResponseEquality req resp1 resp2) $ do

87 unless (getResponseEquality req resp1 resp2) $ do

72 monitor (counterexample "hi" )

88 monitor (counterexample "hi" )

73− run $ modifyMVar_ deetsMVar $ const $ return $

74− ServerEqualityFailure req1 resp1 resp2

89+ _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2

75 assert False

90 assert False

76 case r of

91 case r of

77 Success {} -> return ()

92 Success {} -> return ()

78− f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $

93+ Failure{..} -> do

94+ mx <- tryReadMVar deetsMVar

95+ case mx of

96+ Just x ->

79− "Failed:\n" ++ show x

97+ expectationFailure $ "Failed:\n" ++ show x

98+ Nothing ->

99+ expectationFailure $ "We failed to record a reason for failure: " <> show r

80 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

100 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

81− NoExpectedFailure {} -> expectationFailure $ "No expected failure"

101+ NoExpectedFailure {} -> expectationFailure "No expected failure"

102+#if MIN_VERSION_QuickCheck(2,12,0)

103+#else

82− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

104+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"

105+#endif

106

84-- | Check that a server satisfies the set of properties specified.

107-- | Check that a server satisfies the set of properties specified.

85--

108--

@@ -102,40 +125,68 @@ serversEqual api burl1 burl2 args req = do

102-- /Since 0.0.0.0/

125-- /Since 0.0.0.0/

103serverSatisfies :: (HasGenRequest a) =>

126serverSatisfies :: (HasGenRequest a) =>

104 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation

127 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation

105−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

106− let reqs = ($ burl) <$> genRequest api

139+ let reqs = ($ burl) <$> runGenRequest api

107− deetsMVar <- newMVar $ error "should not be called"

140+ deetsMVar <- newEmptyMVar

108 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do

141 r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do

109− v <- run $ finishPredicates preds (noCheckStatus req) defManager

142+ v <- run $ finishPredicates preds (noCheckStatus req) manager

110− run $ modifyMVar_ deetsMVar $ const $ return v

143+ _ <- run $ tryPutMVar deetsMVar v

111− case v of

144+ case v of

112− Just x -> assert False

145+ Just _ -> assert False

113− _ -> return ()

146+ _ -> return ()

114 case r of

147 case r of

115 Success {} -> return ()

148 Success {} -> return ()

116− f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $

149+ Failure {..} -> do

150+ mx <- tryReadMVar deetsMVar

151+ case mx of

152+ Just x ->

117− "Failed:\n" ++ show x

153+ expectationFailure $ "Failed:\n" ++ show x

154+ Nothing ->

155+ expectationFailure $ "We failed to record a reason for failure: " <> show r

118 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

156 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

119 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

157 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

158+#if MIN_VERSION_QuickCheck(2,12,0)

159+#else

120− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

160+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"

121−

161+#endif

122

162

123serverDoesntSatisfy :: (HasGenRequest a) =>

163serverDoesntSatisfy :: (HasGenRequest a) =>

124 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation

164 Proxy a -> BaseUrl -> Args -> Predicates -> Expectation

125−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

126− let reqs = ($ burl) <$> genRequest api

170+ let reqs = ($ burl) <$> runGenRequest api

127 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do

171 r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do

128− v <- run $ finishPredicates preds (noCheckStatus req) defManager

172+ v <- run $ finishPredicates preds (noCheckStatus req) manager

129 assert $ not $ null v

173 assert $ not $ null v

130 case r of

174 case r of

131 Success {} -> return ()

175 Success {} -> return ()

132 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

176 GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"

133 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m

177 Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m

134 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

178 NoExpectedFailure {} -> expectationFailure $ "No expected failure"

179+#if MIN_VERSION_QuickCheck(2,12,0)

180+#else

135− InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"

181+ InsufficientCoverage {} -> expectationFailure "Insufficient coverage"

182+#endif

136

183

137noCheckStatus :: C.Request -> C.Request

184noCheckStatus :: C.Request -> C.Request

185+#if MIN_VERSION_http_client(0,5,0)

186+noCheckStatus = id

187+#else

138noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}

188noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}

189+#endif

139

190

140defManager :: C.Manager

191defManager :: C.Manager

141defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings

192defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings

stack.yaml+5−31

@@ -1,36 +1,10 @@

1−# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)

2−resolver: nightly-2016-04-20

1+resolver: nightly-2018-09-03

3−

4−# Local packages, usually specified by relative directory name

5packages:

2packages:

6- '.'

3- '.'

7−

8−# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)

9extra-deps:

4extra-deps:

10−- servant-0.7

5+- hspec-discover-2.5.6

11−- servant-client-0.7

6+- hspec-core-2.5.6

12−- servant-server-0.7

7+- hspec-2.5.6

13−

8+- QuickCheck-2.12

14−# Override default flag values for local packages and extra-deps

15flags: {}

9flags: {}

16−

17−# Extra package databases containing global packages

18extra-package-dbs: []

10extra-package-dbs: []

19−

20−# Control whether we use the GHC we find on the path

21−# system-ghc: true

22−

23−# Require a specific version of stack, using version ranges

24−# require-stack-version: -any # Default

25−# require-stack-version: >= 1.0.0

26−

27−# Override the architecture used by stack, especially useful on Windows

28−# arch: i386

29−# arch: x86_64

30−

31−# Extra directories used by stack for building

32−# extra-include-dirs: [/path/to/dir]

33−# extra-lib-dirs: [/path/to/dir]

34−

35−# Allow a newer minor version of GHC than the snapshot specifies

36−# compiler-check: newer-minor

test/Doctest.hsdeleted−44

@@ -1,44 +0,0 @@

1−module Main where

2−

3−import Data.List (isPrefixOf)

4−import System.Directory

5−import System.FilePath

6−import System.FilePath.Find

7−import Test.DocTest

8−

9−main :: IO ()

10−main = do

11− files <- find always (extension ==? ".hs") "src"

12− mCabalMacrosFile <- getCabalMacrosFile

13− doctest $ "-isrc" : "-Iinclude" :

14− (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++

15− "-XOverloadedStrings" :

16− "-XDeriveFunctor" :

17− "-XFlexibleInstances" :

18− "-XFlexibleContexts" :

19− "-XMultiParamTypeClasses" :

20− "-XDataKinds" :

21− "-XTypeOperators" :

22− "-XGADTs" :

23− files

24−

25−getCabalMacrosFile :: IO (Maybe FilePath)

26−getCabalMacrosFile = do

27− exists <- doesDirectoryExist "dist"

28− if exists

29− then do

30− contents <- getDirectoryContents "dist"

31− let rest = "build" </> "autogen" </> "cabal_macros.h"

32− whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of

33− [x] -> "dist" </> x </> rest

34− [] -> "dist" </> rest

35− xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"

36− ++ show xs ++ "\nTry cabal clean"

37− else return Nothing

38− where

39− whenExists :: FilePath -> IO (Maybe FilePath)

40− whenExists file = do

41− exists <- doesFileExist file

42− return $ if exists

43− then Just file

44− else Nothing

test/Servant/QuickCheck/InternalSpec.hs+260−27

@@ -1,20 +1,33 @@

1{-# LANGUAGE CPP #-}

2module Servant.QuickCheck.InternalSpec (spec) where

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−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)

15+import Servant.HTML.Blaze (HTML)

16+import qualified Text.Blaze.Html as Blaze

17+import qualified Text.Blaze.Html5 as Blaze5

9−import Test.Hspec (Spec, context, describe, it,

18+import Test.Hspec (Spec, context, describe, it, shouldBe,

10− pending, shouldBe,

11− shouldContain)

19+ shouldContain)

12−import Test.Hspec.Core.Spec (Arg, Example, Result (..),

20+import Test.Hspec.Core.Spec (Arg, Example, Result (..), ResultStatus (..),

13− defaultParams,

21+ defaultParams, safeEvaluateExample)

14− evaluateExample)

22+import Test.QuickCheck.Gen (generate, unGen)

23+import Test.QuickCheck.Random (mkQCGen)

24+

25+

26+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)

16import Servant.QuickCheck

28import Servant.QuickCheck

17−import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)

29+import Servant.QuickCheck.Internal (genRequest, runGenRequest,

30+ serverDoesntSatisfy)

19spec :: Spec

32spec :: Spec

20spec = do

33spec = do

@@ -22,6 +35,12 @@ spec = do

22 serverSatisfiesSpec

35 serverSatisfiesSpec

23 isComprehensiveSpec

36 isComprehensiveSpec

24 onlyJsonObjectSpec

37 onlyJsonObjectSpec

38+ notLongerThanSpec

39+ queryParamsSpec

40+ queryFlagsSpec

41+ deepPathSpec

42+ htmlDocTypesSpec

43+ unbiasedGenerationSpec

26serversEqualSpec :: Spec

45serversEqualSpec :: Spec

27serversEqualSpec = describe "serversEqual" $ do

46serversEqualSpec = describe "serversEqual" $ do

@@ -32,15 +51,42 @@ serversEqualSpec = describe "serversEqual" $ do

32 serversEqual api burl1 burl2 args bodyEquality

51 serversEqual api burl1 burl2 args bodyEquality

34 context "when servers are not equal" $ do

53 context "when servers are not equal" $ do

35−

36−

37 it "provides the failing responses in the error message" $ do

54 it "provides the failing responses in the error message" $ do

38− Fail _ err <- withServantServer api2 server2 $ \burl1 ->

55+ FailedWith err <- withServantServer api2 server2 $ \burl1 ->

39 withServantServer api2 server3 $ \burl2 -> do

56 withServantServer api2 server3 $ \burl2 -> do

40 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality

57 evalExample $ serversEqual api2 burl1 burl2 args bodyEquality

58+ show err `shouldContain` "Server equality failed"

41 show err `shouldContain` "Body: 1"

59 show err `shouldContain` "Body: 1"

42 show err `shouldContain` "Body: 2"

60 show err `shouldContain` "Body: 2"

43− 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+

45serverSatisfiesSpec :: Spec

91serverSatisfiesSpec :: Spec

46serverSatisfiesSpec = describe "serverSatisfies" $ do

92serverSatisfiesSpec = describe "serverSatisfies" $ do

@@ -62,29 +108,123 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do

62 context "when predicates are false" $ do

108 context "when predicates are false" $ do

109

64 it "fails with informative error messages" $ do

110 it "fails with informative error messages" $ do

65− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do

111+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do

66− evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)

112+ evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)

67− err `shouldContain` "getsHaveCacheControlHeader"

113+ show err `shouldContain` "notAllowedContainsAllowHeader"

68− err `shouldContain` "Headers"

114+ show err `shouldContain` "Headers"

69− err `shouldContain` "Body"

115+ show err `shouldContain` "Body"

116+

117

71onlyJsonObjectSpec :: Spec

118onlyJsonObjectSpec :: Spec

72onlyJsonObjectSpec = describe "onlyJsonObjects" $ do

119onlyJsonObjectSpec = describe "onlyJsonObjects" $ do

120

74 it "fails correctly" $ do

121 it "fails correctly" $ do

75− Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do

122+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do

76 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args

123 evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args

77 (onlyJsonObjects <%> mempty)

124 (onlyJsonObjects <%> mempty)

78− 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)

134

135+notLongerThanSpec :: Spec

136+notLongerThanSpec = describe "notLongerThan" $ do

137+

138+ it "fails correctly" $ do

139+ FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do

140+ evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args

141+ (notLongerThan 1 <%> mempty)

142+ show err `shouldContain` "notLongerThan"

143+

144+ it "succeeds correctly" $ do

145+ withServantServerAndContext api ctx server $ \burl ->

146+ serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)

147

81isComprehensiveSpec :: Spec

148isComprehensiveSpec :: Spec

82isComprehensiveSpec = describe "HasGenRequest" $ do

149isComprehensiveSpec = describe "HasGenRequest" $ do

150

84 it "has instances for all 'servant' combinators" $ do

151 it "has instances for all 'servant' combinators" $ do

85− let _g = genRequest comprehensiveAPI

152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw

86 True `shouldBe` True -- This is a type-level check

153 True `shouldBe` True -- This is a type-level check

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

228

89------------------------------------------------------------------------------

229------------------------------------------------------------------------------

90-- APIs

230-- APIs

@@ -97,6 +237,17 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String

97api :: Proxy API

237api :: Proxy API

98api = Proxy

238api = Proxy

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+

100server :: IO (Server API)

251server :: IO (Server API)

101server = do

252server = do

102 mvar <- newMVar ""

253 mvar <- newMVar ""

@@ -110,23 +261,105 @@ type API2 = "failplz" :> Get '[JSON] Int

110api2 :: Proxy API2

261api2 :: Proxy API2

111api2 = Proxy

262api2 = Proxy

112

263

264+type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()

265+

266+deepAPI :: Proxy DeepAPI

267+deepAPI = Proxy

268+

269+

113server2 :: IO (Server API2)

270server2 :: IO (Server API2)

114server2 = return $ return 1

271server2 = return $ return 1

115

272

116server3 :: IO (Server API2)

273server3 :: IO (Server API2)

117server3 = return $ return 2

274server3 = return $ return 2

118

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+

119ctx :: Context '[BasicAuthCheck ()]

341ctx :: Context '[BasicAuthCheck ()]

120ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext

342ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext

121------------------------------------------------------------------------------

343------------------------------------------------------------------------------

122-- Utils

344-- Utils

123------------------------------------------------------------------------------

345------------------------------------------------------------------------------

124−

125−evalExample :: (Example e, Arg e ~ ()) => e -> IO Result

346+evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult

347+evalExample e = do

126−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"

127 where

353 where

128 progCallback _ = return ()

354 progCallback _ = return ()

129

355

356+data EvalResult

357+ = AnException SomeException

358+ | AllGood

359+ | FailedWith String

360+ deriving (Show)

361+

362+

130args :: Args

363args :: Args

131args = defaultArgs { maxSuccess = noOfTestCases }

364args = defaultArgs { maxSuccess = noOfTestCases }

132

365