199f6cc...master · servant-quickcheck

.travis.yml+154−28

since splitsnapshots

unifiedsplit

@@ -1,32 +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− - STACK_YAML=stack.yaml

17+git:

7− - STACK_YAML=stack-lts-7.yaml

18+ # whether to recursively clone submodules

8− - STACK_YAML=stack-lts-6.yaml

19+ submodules: false

9− - STACK_YAML=stack-lts-9.yaml

20+branches:

10−

21+ only:

11−

22+ - master

12−addons:

23+cache:

13− apt:

24+ directories:

14− packages: libgmp-dev

25+ - $HOME/.cabal/packages

15−

26+ - $HOME/.cabal/store

16−

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

17install:

88install:

18− # stack

89+ - ${CABAL} --version

19− - mkdir -p ~/.local/bin

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

20− - export PATH=~/.local/bin:$PATH

91+ - |

21− - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'

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

22− - stack --version

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

23−

94+ - cat $CABALHOME/config

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

24script:

114script:

25− - stack setup --no-terminal

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

26− - stack build --ghc-options=-Werror --no-terminal

116+ # Packaging...

27− - stack test --ghc-options=-Werror --no-terminal --coverage

117+ - ${CABAL} v2-sdist all

28− - stack haddock --no-terminal

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

29

156

30−cache:

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

31− directories:

158+# EOF

32− - $HOME/.stack

CHANGELOG.yaml+100−3

@@ -1,15 +1,112 @@

1−upcoming:

2−

3releases:

1releases:

2+ - version: "0.0.9.0"

3+ changes:

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

5+ authors: fizruk

6+ date: 2020-06-25

7+

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

9+ authors: felixmulder

10+ date: 2020-06-20

11+

12+ - version: "0.0.8.0"

13+ changes:

14+ - description: Support for servant-0.17

15+ authors: phadej

16+ date: 2019-01-23

17+

18+ - version: "0.0.7.3"

19+ changes:

20+ - description: Support for servant-0.14

21+ issue: 53

22+ authors: phadej

23+ date: 2018-06-12

24+

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

26+ issue: 55

27+ authors: Phenitei

28+ date: 2018-08-27

29+

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

31+ issue: 57

32+ authors: Phenitei

33+ date: 2018-08-29

34+

35+ - description: QuickCheck 2.12 compatibility

36+ issue: 58

37+ authors: parsonsmatt

38+ date: 2018-10-12

39+

40+ - description: GHC 8.6 compatibility

41+ issue: 59

42+ authors: phadej

43+ date: 2018-10-15

44+

45+ - version: "0.0.7.2"

46+ changes:

47+

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

49+ issue: 47

50+ authors: parsonsmatt

51+ date: 2018-05-10

52+

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

54+ issue: 48

55+ authors: parsonsmatt

56+ date: 2018-05-10

57+

58+ - version: "0.0.7.0"

59+ changes:

60+

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

62+ issue: none

63+ authors: phadej

64+ date: 2018-04-12

65+

66+ - version: "0.0.7.0"

67+ changes:

68+

69+ - description: Support for GHC-8.4.1

70+ issue: none

71+ authors: phadej

72+ date: 2018-03-23

73+

74+ - description: Requires hspec-2.5

75+ issue: none

76+ authors: phadej

77+ date: 2018-03-23

4

78

5− - version: "0.0.3.1"

79+ - version: "0.0.6.0"

6 changes:

80 changes:

7

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+

8 - description: Support for Servant 0.11

104 - description: Support for Servant 0.11

9 issue: none

105 issue: none

10 pr: 32

106 pr: 32

11 authors: adinapoli-iohk

107 authors: adinapoli-iohk

12 date: 2017-10-18

108 date: 2017-10-18

109+ notes: Includes 0-weighted instance for EmptyAPI

13

110

14 - version: "0.0.3.0"

111 - version: "0.0.3.0"

15 changes:

112 changes:

cabal.haskell-cinew file+7

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

1+branches: master

2+

3+constraint-set base-compat-0.10

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

5+

6+constraint-set base-compat-0.11

7+ constraints: base-compat ==0.11.*

cabal.projectnew file+4

@@ -0,0 +1,4 @@

1+packages: .

2+tests: true

3+

4+allow-newer: servant-blaze:servant

example/Main.hsnew file+31

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

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

2+module Main (main) where

3+

4+import Servant

5+import Servant.QuickCheck

6+import Test.Hspec

7+import Data.Text (Text)

8+import System.Environment (getArgs)

9+

10+main :: IO ()

11+main = do

12+ args <- getArgs

13+ case args of

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

15+ _ -> hspec spec

16+

17+-- Change to String to reproduce

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

19+type API = Get '[PlainText] Text

20+

21+api :: Proxy API

22+api = Proxy

23+

24+server :: Server API

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

26+

27+spec :: Spec

28+spec = describe "example server" $

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

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

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

servant-quickcheck.cabal+123−94

@@ -1,22 +1,22 @@

1−name: servant-quickcheck

1+name: servant-quickcheck

2−version: 0.0.3.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.

7

8−license: BSD3

8+license: BSD3

9−license-file: LICENSE

9+license-file: LICENSE

10−author: Julian K. Arni

10+author: Julian K. Arni

11−maintainer: jkarni@gmail.com

11+maintainer: jkarni@gmail.com

12−category: Web

12+category: Web

13−build-type: Simple

13+build-type: Simple

14−cabal-version: >=1.10

14+cabal-version: >=1.10

15−extra-source-files:

15+extra-source-files: CHANGELOG.yaml

16− CHANGELOG.yaml

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

17

18source-repository head

19− type: git

19+ type: git

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

21

22flag long-tests

@@ -24,86 +24,115 @@ flag long-tests

24 default: False

25

26library

27− exposed-modules: Servant.QuickCheck

27+ exposed-modules:

28− , Servant.QuickCheck.Internal

28+ Servant.QuickCheck

29− , Servant.QuickCheck.Internal.Predicates

29+ Servant.QuickCheck.Internal

30− , Servant.QuickCheck.Internal.HasGenRequest

31− , Servant.QuickCheck.Internal.QuickCheck

32− , Servant.QuickCheck.Internal.Equality

30+ Servant.QuickCheck.Internal.Equality

33− , Servant.QuickCheck.Internal.ErrorTypes

31+ Servant.QuickCheck.Internal.ErrorTypes

34− build-depends: base >=4.8 && <4.10

32+ Servant.QuickCheck.Internal.HasGenRequest

35− , base-compat == 0.9.*

33+ Servant.QuickCheck.Internal.Predicates

36− , aeson > 0.8 && < 2

37− , bytestring == 0.10.*

38− , case-insensitive == 1.2.*

39− , clock >= 0.7 && < 0.8

40− , data-default-class >= 0.0 && < 0.2

41− , hspec >= 2.2 && < 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

48− , QuickCheck > 2.7 && < 2.11

34+ Servant.QuickCheck.Internal.QuickCheck

49− , servant > 0.6 && < 0.12

50− , servant-client > 0.6 && < 0.12

51− , servant-server > 0.6 && < 0.12

52− , split == 0.2.*

53− , string-conversions > 0.3 && < 0.5

54− , temporary == 1.2.*

55− , text == 1.*

56− , time >= 1.5 && < 1.7

57− , warp >= 3.2.4 && < 3.3

58

35

36+ build-depends:

37+ aeson >=0.8 && <2

38+ , base >=4.9 && <4.15

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

40+ , bytestring >=0.10 && <0.11

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

42+ , clock >=0.7 && <0.9

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

44+ , hspec >=2.5.6 && <2.8

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

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

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

48+ , mtl >=2.1 && <2.3

49+ , pretty >=1.1 && <1.2

50+ , process >=1.2 && <1.7

51+ , QuickCheck >=2.7 && <2.15

52+ , servant >=0.17 && <0.19

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

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

55+ , split >=0.2 && <0.3

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

57+ , temporary >=1.2 && <1.4

58+ , text >=1 && <2

59+ , time >=1.5 && <1.11

60+ , warp >=3.2.4 && <3.4

61+

62+ if !impl(ghc >=8.0)

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

64+

59− hs-source-dirs: src

65+ hs-source-dirs: src

60− default-extensions: TypeOperators

66+ default-extensions:

67+ NoImplicitPrelude

68+ ConstraintKinds

69+ DataKinds

70+ DeriveDataTypeable

71+ DeriveFunctor

72+ DeriveGeneric

73+ FlexibleContexts

61− , FlexibleInstances

74+ FlexibleInstances

62− , FlexibleContexts

75+ FunctionalDependencies

63− , DataKinds

64− , GADTs

76+ GADTs

77+ KindSignatures

65− , MultiParamTypeClasses

78+ MultiParamTypeClasses

66− , DeriveFunctor

79+ OverloadedStrings

67− , KindSignatures

68− , RankNTypes

80+ RankNTypes

69− , ConstraintKinds

70− , DeriveGeneric

71− , ScopedTypeVariables

81+ ScopedTypeVariables

72− , OverloadedStrings

82+ TypeOperators

73− , FunctionalDependencies

83+

74− , NoImplicitPrelude

75− , DeriveDataTypeable

76− default-language: Haskell2010

84+ default-language: Haskell2010

77

85

78test-suite spec

86test-suite spec

79− type: exitcode-stdio-1.0

87+ type: exitcode-stdio-1.0

80− ghc-options: -Wall -threaded

88+ ghc-options: -Wall -threaded

81− default-language: Haskell2010

89+ default-language: Haskell2010

82− hs-source-dirs: test

90+ hs-source-dirs: test

83− main-is: Spec.hs

91+ main-is: Spec.hs

84− other-modules: Servant.QuickCheck.InternalSpec

92+ other-modules: Servant.QuickCheck.InternalSpec

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

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

94+ build-depends:

95+ aeson

96+ , base

86− , base-compat

97+ , base-compat-batteries

87− , aeson

98+ , blaze-html

88− , servant-quickcheck

89− , bytestring

99+ , bytestring

90− , hspec

100+ , hspec

91− , hspec-core

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

92− , http-client

102+ , http-client

93− , warp

103+ , QuickCheck

104+ , quickcheck-io

105+ , servant

106+ , servant-blaze

107+ , servant-client

108+ , servant-quickcheck

94− , servant-server

109+ , servant-server

95− , servant-client

96− , servant

97− , transformers

110+ , transformers

98− , QuickCheck

111+ , warp

99− , quickcheck-io

112+

100− default-extensions: TypeOperators

113+ default-extensions:

101− , FlexibleInstances

114+ NoImplicitPrelude

115+ DataKinds

102− , FlexibleContexts

116+ FlexibleContexts

117+ FlexibleInstances

103− , GADTs

118+ GADTs

104− , DataKinds

105− , NoImplicitPrelude

106− , OverloadedStrings

119+ OverloadedStrings

107− , ScopedTypeVariables

120+ ScopedTypeVariables

121+ TypeOperators

122+

108 if flag(long-tests)

123 if flag(long-tests)

109− 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+5

@@ -29,11 +29,16 @@ module Servant.QuickCheck

29 , not500

30 , notLongerThan

31 , onlyJsonObjects

32+ , honoursAcceptHeader

32 , notAllowedContainsAllowHeader

33 , notAllowedContainsAllowHeader

33 , unauthorizedContainsWWWAuthenticate

34 , unauthorizedContainsWWWAuthenticate

35+ , getsHaveLastModifiedHeader

34 , getsHaveCacheControlHeader

36 , getsHaveCacheControlHeader

35 , headsHaveCacheControlHeader

37 , headsHaveCacheControlHeader

36 , createContainsValidLocation

38 , createContainsValidLocation

39+ -- * Html Predicates

40+ , htmlIncludesDoctype

41+

37 -- *** Predicate utilities and types

42 -- *** Predicate utilities and types

38 , (<%>)

43 , (<%>)

39 , Predicates

44 , Predicates

src/Servant/QuickCheck/Internal/Equality.hs+6−2

@@ -5,15 +5,19 @@ import Data.ByteString (ByteString)

5import qualified Data.ByteString.Lazy as LB

6import Data.Function (on)

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

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

8import Prelude.Compat

9import Prelude.Compat

9

10

10newtype ResponseEquality b

11newtype ResponseEquality b

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

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

12

13

14+instance Semigroup (ResponseEquality b) where

15+ ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y ->

16+ a x y && b x y

17+

13instance Monoid (ResponseEquality b) where

18instance Monoid (ResponseEquality b) where

14 mempty = ResponseEquality $ \_ _ -> True

19 mempty = ResponseEquality $ \_ _ -> True

15− ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->

20+ mappend = (<>)

16− a x y && b x y

17

21

18-- | Use `Eq` instance for `Response`

22-- | Use `Eq` instance for `Response`

19--

23--

src/Servant/QuickCheck/Internal/ErrorTypes.hs+3−1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1module Servant.QuickCheck.Internal.ErrorTypes where

2module Servant.QuickCheck.Internal.ErrorTypes where

2

3

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

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

@@ -8,9 +9,10 @@ import Data.Typeable (Typeable)

8import GHC.Generics (Generic)

9import GHC.Generics (Generic)

9import qualified Network.HTTP.Client as C

10import qualified Network.HTTP.Client as C

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

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

11−import Prelude.Compat

12import Text.PrettyPrint

13

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

15+

14data PredicateFailure

16data PredicateFailure

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

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

16 deriving (Typeable, Generic)

18 deriving (Typeable, Generic)

src/Servant/QuickCheck/Internal/HasGenRequest.hs+22−12

@@ -2,7 +2,6 @@

2{-# LANGUAGE PolyKinds #-}

3module Servant.QuickCheck.Internal.HasGenRequest where

4

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

6import Data.String (fromString)

5import Data.String (fromString)

7import Data.String.Conversions (cs)

6import Data.String.Conversions (cs)

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

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

@@ -64,13 +63,17 @@ instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where

64 (oldf, old) = genRequest (Proxy :: Proxy b)

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

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

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

66

65

67−#if MIN_VERSION_servant(0,11,0)

68instance HasGenRequest EmptyAPI where

66instance HasGenRequest EmptyAPI where

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

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

70−#endif

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)

71

74

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

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

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

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

74 genRequest _ = (oldf, do

77 genRequest _ = (oldf, do

75 old' <- old

78 old' <- old

76 new' <- toUrlPiece <$> new

79 new' <- toUrlPiece <$> new

@@ -79,7 +82,6 @@ instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )

79 (oldf, old) = genRequest (Proxy :: Proxy b)

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

80 new = arbitrary :: Gen c

83 new = arbitrary :: Gen c

81

84

82−#if MIN_VERSION_servant(0,8,0)

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

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

84 => HasGenRequest (CaptureAll x c :> b) where

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

85 genRequest _ = (oldf, do

87 genRequest _ = (oldf, do

@@ -90,13 +92,12 @@ instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )

90 where

92 where

91 (oldf, old) = genRequest (Proxy :: Proxy b)

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

92 new = arbitrary :: Gen [c]

94 new = arbitrary :: Gen [c]

93−#endif

94

95

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

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

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

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

97 genRequest _ = (oldf, do

98 genRequest _ = (oldf, do

98 old' <- old

99 old' <- old

99− new' <- toUrlPiece <$> new

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

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

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

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

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

102 where

103 where

@@ -105,9 +106,9 @@ instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)

105 new = arbitrary :: Gen c

106 new = arbitrary :: Gen c

106

107

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

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

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

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

109 genRequest _ = (oldf, do

110 genRequest _ = (oldf, do

110− old' <- old

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

111 new' <- new

112 new' <- new

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

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

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

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

@@ -119,9 +120,9 @@ instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)

119 new = arbitrary :: Gen c

120 new = arbitrary :: Gen c

120

121

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

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

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

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

123 genRequest _ = (oldf, do

124 genRequest _ = (oldf, do

124− new' <- new

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

125 old' <- old

126 old' <- old

126 return $ \burl -> let r = old' burl

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

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

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

@@ -167,6 +168,15 @@ instance (ReflectMethod method)

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

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

168 })

169 })

169

170

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+

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

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

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

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

172

182

src/Servant/QuickCheck/Internal/Predicates.hs+63−31

@@ -7,11 +7,12 @@ import Data.Bifunctor (first)

7import qualified Data.ByteString as SBS

8import qualified Data.ByteString.Char8 as SBSC

9import qualified Data.ByteString.Lazy as LBS

10−import Data.CaseInsensitive (mk, foldedCase)

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

11import Data.Either (isRight)

12import Data.List.Split (wordsBy)

13import Data.Maybe (fromMaybe, isJust)

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

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

15+import qualified Data.Text as T

15import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,

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

16 rfc822DateFormat)

17 rfc822DateFormat)

17import GHC.Generics (Generic)

18import GHC.Generics (Generic)

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

42-- /Since 0.0.0.0/

43-- /Since 0.0.0.0/

43not500 :: ResponsePredicate

44not500 :: ResponsePredicate

44not500 = ResponsePredicate $ \resp ->

45not500 = ResponsePredicate $ \resp ->

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

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

46

47

47-- | [__Optional__]

48-- | [__Optional__]

48--

49--

@@ -83,15 +84,13 @@ notLongerThan maxAllowed

83-- /Since 0.0.0.0/

84-- /Since 0.0.0.0/

84onlyJsonObjects :: ResponsePredicate

85onlyJsonObjects :: ResponsePredicate

85onlyJsonObjects

86onlyJsonObjects

86− = ResponsePredicate (\resp -> case go resp of

87+ = ResponsePredicate (\resp -> do

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

88− Just () -> return ())

89− where

90− go r = do

91− ctyp <- lookup "content-type" (first foldedCase <$> responseHeaders r)

88+ case lookup "content-type" (first foldedCase <$> responseHeaders resp) of

89+ Nothing -> return ()

92− when ("application/json" `SBS.isPrefixOf` ctyp) $ do

90+ Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do

93− (_ :: Object) <- decode (responseBody r)

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

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

94− return ()

93+ Just _ -> return ())

95

94

96-- | __Optional__

95-- | __Optional__

97--

96--

@@ -119,12 +118,12 @@ createContainsValidLocation

119 resp <- httpLbs req mgr

118 resp <- httpLbs req mgr

120 if responseStatus resp == status201

119 if responseStatus resp == status201

121 then case lookup "Location" $ responseHeaders resp of

120 then case lookup "Location" $ responseHeaders resp of

122− Nothing -> fail n

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

123 Just l -> case parseRequest $ SBSC.unpack l of

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

124− Nothing -> fail n

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

125 Just x -> do

124 Just x -> do

126 resp2 <- httpLbs x mgr

125 resp2 <- httpLbs x mgr

127− status2XX resp2 n

126+ status2XX (Just req) resp2 n

128 return [resp, resp2]

127 return [resp, resp2]

129 else return [resp]

128 else return [resp]

130

129

@@ -188,14 +187,15 @@ getsHaveLastModifiedHeader

188notAllowedContainsAllowHeader :: RequestPredicate

187notAllowedContainsAllowHeader :: RequestPredicate

189notAllowedContainsAllowHeader

188notAllowedContainsAllowHeader

190 = RequestPredicate $ \req mgr -> do

189 = RequestPredicate $ \req mgr -> do

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

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

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

193− , renderStdMethod m /= method req ]

191+ , renderStdMethod m /= method req ]

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

193+

194− case filter pred' resp of

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

195− (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x

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

196 [] -> return resp

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

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

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

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

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

226 if status100 < scode && scode < status300

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

228− then fail "honoursAcceptHeader"

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

229 else return [resp]

230 else return [resp]

231

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

336 = ResponsePredicate $ \resp ->

337 if responseStatus resp == status401

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

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

340 else return ()

362 else return ()

341

363

342-- * Predicate logic

364-- * Predicate logic

@@ -354,9 +376,12 @@ newtype ResponsePredicate = ResponsePredicate

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

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

355 } deriving (Generic)

377 } deriving (Generic)

356

378

379+instance Semigroup ResponsePredicate where

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

381+

357instance Monoid ResponsePredicate where

382instance Monoid ResponsePredicate where

358 mempty = ResponsePredicate $ const $ return ()

383 mempty = ResponsePredicate $ const $ return ()

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

384+ mappend = (<>)

360

385

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

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

362--

387--

@@ -368,7 +393,11 @@ newtype RequestPredicate = RequestPredicate

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

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

369instance Monoid RequestPredicate where

394instance Monoid RequestPredicate where

370 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

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

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

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

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

373

402

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

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

@@ -377,10 +406,13 @@ data Predicates = Predicates

377 , responsePredicates :: ResponsePredicate

406 , responsePredicates :: ResponsePredicate

378 } deriving (Generic)

407 } deriving (Generic)

379

408

409+instance Semigroup Predicates where

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

411+ (responsePredicates a <> responsePredicates b)

412+

380instance Monoid Predicates where

413instance Monoid Predicates where

381 mempty = Predicates mempty mempty

414 mempty = Predicates mempty mempty

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

415+ mappend = (<>)

383− (responsePredicates a <> responsePredicates b)

384

416

385class JoinPreds a where

417class JoinPreds a where

386 joinPreds :: a -> Predicates -> Predicates

418 joinPreds :: a -> Predicates -> Predicates

@@ -422,8 +454,8 @@ isRFC822Date s

422 Nothing -> False

454 Nothing -> False

423 Just (_ :: UTCTime) -> True

455 Just (_ :: UTCTime) -> True

424

456

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

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

426−status2XX r t

458+status2XX mreq resp t

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

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

428 = return ()

460 = return ()

429− | otherwise = fail t

461+ | otherwise = throw $ PredicateFailure t mreq resp

src/Servant/QuickCheck/Internal/QuickCheck.hs+58−19

@@ -2,7 +2,7 @@

2{-# LANGUAGE CPP #-}

3module Servant.QuickCheck.Internal.QuickCheck where

4

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

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

6import Control.Monad (unless)

7import qualified Data.ByteString.Lazy as LBS

8import Data.Proxy (Proxy)

@@ -11,6 +11,9 @@ import 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)

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

37-- application.

40-- application.

38--

41--

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

40withServantServerAndContext :: HasServer a ctx

46withServantServerAndContext :: HasServer a ctx

47+#endif

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

42withServantServerAndContext api ctx server t

49withServantServerAndContext api ctx server t

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

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

@@ -73,21 +80,29 @@ serversEqual api burl1 burl2 args req = do

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

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

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

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

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

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

83+ deetsMVar <- newEmptyMVar

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

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

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

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

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

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

80 unless (getResponseEquality req resp1 resp2) $ do

87 unless (getResponseEquality req resp1 resp2) $ do

81 monitor (counterexample "hi" )

88 monitor (counterexample "hi" )

82− run $ modifyMVar_ deetsMVar $ const $ return $

83− ServerEqualityFailure req1 resp1 resp2

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

84 assert False

90 assert False

85 case r of

91 case r of

86 Success {} -> return ()

92 Success {} -> return ()

93+ Failure{..} -> do

94+ mx <- tryReadMVar deetsMVar

95+ case mx of

96+ Just x ->

87− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $ "Failed:\n" ++ show x

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

98+ Nothing ->

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

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

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

89 NoExpectedFailure {} -> expectationFailure "No expected failure"

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

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

103+#else

90 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"

104 InsufficientCoverage {} -> expectationFailure "Insufficient coverage"

105+#endif

91

106

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

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

93--

108--

@@ -110,37 +125,61 @@ serversEqual api burl1 burl2 args req = do

110-- /Since 0.0.0.0/

125-- /Since 0.0.0.0/

111serverSatisfies :: (HasGenRequest a) =>

126serverSatisfies :: (HasGenRequest a) =>

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

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

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

114 let reqs = ($ burl) <$> runGenRequest api

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

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

140+ deetsMVar <- newEmptyMVar

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

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

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

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

118− run $ modifyMVar_ deetsMVar $ const $ return v

143+ _ <- run $ tryPutMVar deetsMVar v

119− case v of

144+ case v of

120− Just _ -> assert False

145+ Just _ -> assert False

121− _ -> return ()

146+ _ -> return ()

122 case r of

147 case r of

123 Success {} -> return ()

148 Success {} -> return ()

124− Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $

149+ Failure {..} -> do

150+ mx <- tryReadMVar deetsMVar

151+ case mx of

152+ Just x ->

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

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

154+ Nothing ->

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

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

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

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

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

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

159+#else

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

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

129−

161+#endif

130

162

131serverDoesntSatisfy :: (HasGenRequest a) =>

163serverDoesntSatisfy :: (HasGenRequest a) =>

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

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

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

134 let reqs = ($ burl) <$> runGenRequest api

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

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

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

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

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

137 assert $ not $ null v

173 assert $ not $ null v

138 case r of

174 case r of

139 Success {} -> return ()

175 Success {} -> return ()

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

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

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

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

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

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

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

180+#else

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

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

182+#endif

144

183

145noCheckStatus :: C.Request -> C.Request

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

146#if MIN_VERSION_http_client(0,5,0)

185#if MIN_VERSION_http_client(0,5,0)

stack-lts-6.yamldeleted−6

@@ -1,6 +0,0 @@

1−resolver: lts-6.30

2−packages:

3−- '.'

4−extra-deps: []

5−flags: {}

6−extra-package-dbs: []

stack-lts-7.yamldeleted−6

@@ -1,6 +0,0 @@

1−resolver: lts-7.19

2−packages:

3−- '.'

4−extra-deps: []

5−flags: {}

6−extra-package-dbs: []

stack-lts-9.yamldeleted−6

@@ -1,6 +0,0 @@

1−resolver: lts-9.1

2−packages:

3−- '.'

4−extra-deps: []

5−flags: {}

6−extra-package-dbs: []

stack.yaml+5−5

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

1−resolver: lts-8.4

1+resolver: nightly-2018-09-03

2packages:

3- '.'

4extra-deps:

5−- hspec-2.4.4

5+- hspec-discover-2.5.6

6−- hspec-core-2.4.4

6+- hspec-core-2.5.6

7−- hspec-discover-2.4.4

7+- hspec-2.5.6

8−- quickcheck-io-0.2.0

8+- QuickCheck-2.12

9flags: {}

10extra-package-dbs: []

test/Doctest.hsdeleted−44

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

1−module Main where

2−

3−import Data.List (isPrefixOf)

4−import System.Directory

5−import System.FilePath

6−import System.FilePath.Find

7−import Test.DocTest

8−

9−main :: IO ()

10−main = do

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

12− mCabalMacrosFile <- getCabalMacrosFile

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

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

15− "-XOverloadedStrings" :

16− "-XDeriveFunctor" :

17− "-XFlexibleInstances" :

18− "-XFlexibleContexts" :

19− "-XMultiParamTypeClasses" :

20− "-XDataKinds" :

21− "-XTypeOperators" :

22− "-XGADTs" :

23− files

24−

25−getCabalMacrosFile :: IO (Maybe FilePath)

26−getCabalMacrosFile = do

27− exists <- doesDirectoryExist "dist"

28− if exists

29− then do

30− contents <- getDirectoryContents "dist"

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

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

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

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

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

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

37− else return Nothing

38− where

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

40− whenExists file = do

41− exists <- doesFileExist file

42− return $ if exists

43− then Just file

44− else Nothing

test/Servant/QuickCheck/InternalSpec.hs+51−38

@@ -12,27 +12,18 @@ import Data.Maybe (fromJust)

12import Network.HTTP.Client (path, queryString)

13import Prelude.Compat

14import Servant

15+import Servant.HTML.Blaze (HTML)

16+import qualified Text.Blaze.Html as Blaze

17+import qualified Text.Blaze.Html5 as Blaze5

15import Test.Hspec (Spec, context, describe, it, shouldBe,

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

16 shouldContain)

19 shouldContain)

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

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

18− defaultParams)

21+ defaultParams, safeEvaluateExample)

19import Test.QuickCheck.Gen (generate, unGen)

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

20import Test.QuickCheck.Random (mkQCGen)

23import Test.QuickCheck.Random (mkQCGen)

21

24

22

25

23−#if MIN_VERSION_servant(0,8,0)

24−import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)

26+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)

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

36

27

37import Servant.QuickCheck

28import Servant.QuickCheck

38import Servant.QuickCheck.Internal (genRequest, runGenRequest,

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

@@ -48,6 +39,7 @@ spec = do

48 queryParamsSpec

39 queryParamsSpec

49 queryFlagsSpec

40 queryFlagsSpec

50 deepPathSpec

41 deepPathSpec

42+ htmlDocTypesSpec

51 unbiasedGenerationSpec

43 unbiasedGenerationSpec

52

44

53serversEqualSpec :: Spec

45serversEqualSpec :: Spec

@@ -136,6 +128,10 @@ onlyJsonObjectSpec = describe "onlyJsonObjects" $ do

136 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->

128 withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->

137 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)

129 serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)

138

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+

139notLongerThanSpec :: Spec

135notLongerThanSpec :: Spec

140notLongerThanSpec = describe "notLongerThan" $ do

136notLongerThanSpec = describe "notLongerThan" $ do

141

137

@@ -153,7 +149,7 @@ isComprehensiveSpec :: Spec

153isComprehensiveSpec = describe "HasGenRequest" $ do

149isComprehensiveSpec = describe "HasGenRequest" $ do

154

150

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

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

156− let _g = genRequest comprehensiveAPIWithoutRaw

152+ let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw

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

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

158

154

159deepPathSpec :: Spec

155deepPathSpec :: Spec

@@ -189,6 +185,25 @@ queryFlagsSpec = describe "QueryFlags" $ do

189 qs = C.unpack $ queryString req

185 qs = C.unpack $ queryString req

190 qs `shouldBe` "one&two"

186 qs `shouldBe` "one&two"

191

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+

192makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer

207makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer

193makeRandomRequest large burl = do

208makeRandomRequest large burl = do

194 req <- generate $ runGenRequest large

209 req <- generate $ runGenRequest large

@@ -258,7 +273,23 @@ server2 = return $ return 1

258server3 :: IO (Server API2)

273server3 :: IO (Server API2)

259server3 = return $ return 2

274server3 = return $ return 2

260

275

276+serverFailing :: IO (Server API2)

277+serverFailing = return . throwError $ err405

278+

279+-- With Doctypes

280+type HtmlDoctype = Get '[HTML] Blaze.Html

261

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

262largeApi :: Proxy LargeAPI

293largeApi :: Proxy LargeAPI

263largeApi = Proxy

294largeApi = Proxy

264

295

@@ -313,27 +344,14 @@ ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext

313-- Utils

344-- Utils

314------------------------------------------------------------------------------

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

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

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

316−#if MIN_VERSION_hspec(2,4,0)

317evalExample e = do

347evalExample e = do

318 r <- safeEvaluateExample e defaultParams ($ ()) progCallback

348 r <- safeEvaluateExample e defaultParams ($ ()) progCallback

319− case r of

349+ case resultStatus r of

320− Left err -> return $ AnException err

321− Right Success -> return $ AllGood

350+ Success -> return $ AllGood

322− Right (Failure _ reason) -> return $ FailedWith $ show reason

351+ Failure _ reason -> return $ FailedWith $ show reason

323− Right (Pending _) -> error "should not happen"

352+ Pending {} -> error "should not happen"

324 where

353 where

325 progCallback _ = return ()

354 progCallback _ = return ()

326−#else

327−evalExample e = do

328− r <- try $ evaluateExample e defaultParams ($ ()) progCallback

329− case r of

330− Left err -> return $ AnException err

331− Right Success -> return $ AllGood

332− Right (Fail _ reason) -> return $ FailedWith reason

333− Right (Pending _) -> error "should not happen"

334− where

335− progCallback _ = return ()

336−#endif

337

355

338data EvalResult

356data EvalResult

339 = AnException SomeException

357 = AnException SomeException

@@ -351,8 +369,3 @@ noOfTestCases = 20000

351#else

369#else

352noOfTestCases = 1000

370noOfTestCases = 1000

353#endif

371#endif

354−

355−#if !MIN_VERSION_servant(0,8,0)

356−comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPI

357−comprehensiveAPIWithoutRaw = comprehensiveAPI

358−#endif