Merge pull request #72 from maksbotan/maksbotan/support-servant-0.18

Support servant-server-0.18
Update src/Servant/QuickCheck/Internal/QuickCheck.hs
2020-07-31 09:54:59 +02:00 · 2020-07-31 10:43:19 +03:00 · 2020-07-30 19:32:29 +03:00 · 2020-07-30 19:22:14 +03:00 · 2020-07-10 13:54:21 +02:00 · 2020-07-02 22:40:04 +02:00
17 changed files with 1099 additions and 311 deletions
--- a/.gitignore
+++ b/.gitignore
@ -3,3 +3,4 @@ scripts/
 samples/
 test-servers/
 /doc/
+.stack-work/
--- a/.travis.yml
+++ b/.travis.yml
@ -1,26 +1,158 @@
-sudo: false
-
+# This Travis job script has been generated by a script via
+#
+#   haskell-ci '--config=cabal.haskell-ci' 'servant-quickcheck.cabal'
+#
+# To regenerate the script (for example after adjusting tested-with) run
+#
+#   haskell-ci regenerate
+#
+# For more information, see https://github.com/haskell-CI/haskell-ci
+#
+# version: 0.10.1
+#
+version: ~> 1.0
 language: c
-
-matrix:
-  include:
-    - env: CABALVER=1.22 GHCVER=7.10.1
-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1],sources: [hvr-ghc]}}
-    - env: CABALVER=1.24 GHCVER=8.0.1
-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1],  sources: [hvr-ghc]}}
-
-install:
-  - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
-  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
-  - ghc --version
-  - cabal --version
-  - travis_retry cabal update
-  - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
-
-script:
-  - tinc && cabal configure --enable-tests && cabal build && cabal test
-  - cabal check
-
+os: linux
+dist: xenial
+git:
+  # whether to recursively clone submodules
+  submodules: false
+branches:
+  only:
+    - master
 cache:
  directories:
-    - $HOME/.tinc/cache
+    - $HOME/.cabal/packages
+    - $HOME/.cabal/store
+    - $HOME/.hlint
+before_cache:
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
+  # remove files that are regenerated by 'cabal update'
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
+  - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
+  - rm -rfv $CABALHOME/packages/head.hackage
+jobs:
+  include:
+    - compiler: ghc-8.8.3
+      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"]}}
+      os: linux
+    - compiler: ghc-8.6.5
+      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"]}}
+      os: linux
+    - compiler: ghc-8.4.4
+      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"]}}
+      os: linux
+    - compiler: ghc-8.2.2
+      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"]}}
+      os: linux
+    - compiler: ghc-8.0.2
+      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"]}}
+      os: linux
+before_install:
+  - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
+  - WITHCOMPILER="-w $HC"
+  - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//')
+  - HCPKG="$HC-pkg"
+  - unset CC
+  - CABAL=/opt/ghc/bin/cabal
+  - CABALHOME=$HOME/.cabal
+  - export PATH="$CABALHOME/bin:$PATH"
+  - TOP=$(pwd)
+  - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
+  - echo $HCNUMVER
+  - CABAL="$CABAL -vnormal+nowrap"
+  - set -o pipefail
+  - TEST=--enable-tests
+  - BENCH=--enable-benchmarks
+  - HEADHACKAGE=false
+  - rm -f $CABALHOME/config
+  - |
+    echo "verbose: normal +nowrap +markoutput"          >> $CABALHOME/config
+    echo "remote-build-reporting: anonymous"            >> $CABALHOME/config
+    echo "write-ghc-environment-files: always"          >> $CABALHOME/config
+    echo "remote-repo-cache: $CABALHOME/packages"       >> $CABALHOME/config
+    echo "logs-dir:          $CABALHOME/logs"           >> $CABALHOME/config
+    echo "world-file:        $CABALHOME/world"          >> $CABALHOME/config
+    echo "extra-prog-path:   $CABALHOME/bin"            >> $CABALHOME/config
+    echo "symlink-bindir:    $CABALHOME/bin"            >> $CABALHOME/config
+    echo "installdir:        $CABALHOME/bin"            >> $CABALHOME/config
+    echo "build-summary:     $CABALHOME/logs/build.log" >> $CABALHOME/config
+    echo "store-dir:         $CABALHOME/store"          >> $CABALHOME/config
+    echo "install-dirs user"                            >> $CABALHOME/config
+    echo "  prefix: $CABALHOME"                         >> $CABALHOME/config
+    echo "repository hackage.haskell.org"               >> $CABALHOME/config
+    echo "  url: http://hackage.haskell.org/"           >> $CABALHOME/config
+install:
+  - ${CABAL} --version
+  - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
+  - |
+    echo "program-default-options"                >> $CABALHOME/config
+    echo "  ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config
+  - cat $CABALHOME/config
+  - rm -fv cabal.project cabal.project.local cabal.project.freeze
+  - travis_retry ${CABAL} v2-update -v
+  # Generate cabal.project
+  - rm -rf cabal.project cabal.project.local cabal.project.freeze
+  - touch cabal.project
+  - |
+    echo "packages: ." >> cabal.project
+  - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi
+  - "if [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - |
+  - "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"
+  - cat cabal.project || true
+  - cat cabal.project.local || true
+  - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
+  - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH}
+  - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
+  - rm  cabal.project.freeze
+  - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all
+  - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all
+script:
+  - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
+  # Packaging...
+  - ${CABAL} v2-sdist all
+  # Unpacking...
+  - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
+  - cd ${DISTDIR} || false
+  - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
+  - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm       '{}' \;
+  - PKGDIR_servant_quickcheck="$(find . -maxdepth 1 -type d -regex '.*/servant-quickcheck-[0-9.]*')"
+  # Generate cabal.project
+  - rm -rf cabal.project cabal.project.local cabal.project.freeze
+  - touch cabal.project
+  - |
+    echo "packages: ${PKGDIR_servant_quickcheck}" >> cabal.project
+  - if [ $HCNUMVER -ge 80200 ] ; then echo 'package servant-quickcheck' >> cabal.project ; fi
+  - "if [ $HCNUMVER -ge 80200 ] ; then echo '  ghc-options: -Werror=missing-methods' >> cabal.project ; fi"
+  - |
+  - "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"
+  - cat cabal.project || true
+  - cat cabal.project.local || true
+  # Building...
+  # this builds all libraries and executables (without tests/benchmarks)
+  - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
+  # Building with tests and benchmarks...
+  # build & run tests, build benchmarks
+  - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all
+  # Testing...
+  - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all
+  # cabal check...
+  - (cd ${PKGDIR_servant_quickcheck} && ${CABAL} -vnormal check)
+  # haddock...
+  - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all
+  # Building without installed constraints for packages in global-db...
+  - rm -f cabal.project.local
+  - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all
+  # Constraint sets
+  - rm -rf cabal.project.local
+  # Constraint set base-compat-0.10
+  - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.10.*' all
+  # Constraint set base-compat-0.11
+  - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='base-compat ==0.11.*' all
+
+# REGENDATA ("0.10.1",["--config=cabal.haskell-ci","servant-quickcheck.cabal"])
+# EOF
--- a/CHANGELOG.yaml
+++ b/CHANGELOG.yaml
@ -1,6 +1,174 @@
-upcoming:
-
 releases:
+  - version: "0.0.9.0"
+    changes:
+      - description: "Support servant-0.15 (#65)"
+        authors: fizruk
+        date: 2020-06-25
+
+      - description: "Relax constraints for GHC 8.10 (#70)"
+        authors: felixmulder
+        date: 2020-06-20
+
+  - version: "0.0.8.0"
+    changes:
+      - description: Support for servant-0.17
+        authors: phadej
+        date: 2019-01-23
+
+  - version: "0.0.7.3"
+    changes:
+      - description: Support for servant-0.14
+        issue: 53
+        authors: phadej
+        date: 2018-06-12
+
+      - description: Fix a failure from OnlyJsonObjects when there is no content-type.
+        issue: 55
+        authors: Phenitei
+        date: 2018-08-27
+
+      - description: A bug fix where notAllowedContainsAllowHeader would print the initial request alongside the failure instead of the request causing the failure when it failed.
+        issue: 57
+        authors: Phenitei
+        date: 2018-08-29
+
+      - description: QuickCheck 2.12 compatibility
+        issue: 58
+        authors: parsonsmatt
+        date: 2018-10-12
+
+      - description: GHC 8.6 compatibility
+        issue: 59
+        authors: phadej
+        date: 2018-10-15
+
+  - version: "0.0.7.2"
+    changes:
+
+      - description: Allow client to pass an HTTP Manager in to functions
+        issue: 47
+        authors: parsonsmatt
+        date: 2018-05-10
+
+      - description: Fix "should not happen" error when exceptions are thrown
+        issue: 48
+        authors: parsonsmatt
+        date: 2018-05-10
+
+  - version: "0.0.7.0"
+    changes:
+
+      - description: Support for base-compat-0.10
+        issue: none
+        authors: phadej
+        date: 2018-04-12
+
+  - version: "0.0.7.0"
+    changes:
+
+      - description: Support for GHC-8.4.1
+        issue: none
+        authors: phadej
+        date: 2018-03-23
+
+      - description: Requires hspec-2.5
+        issue: none
+        authors: phadej
+        date: 2018-03-23
+
+  - version: "0.0.6.0"
+    changes:
+
+      - description: Support for servant-0.12
+        issue: none
+        authors: phadej
+        date: 2018-02-09
+
+  - version: "0.0.5.0"
+    changes:
+
+      - description: Export forgotten predicates
+        issue: none
+        pr: 40
+        authors: Phenitei
+        date: 2017-12-14
+
+  - version: "0.0.4"
+    changes:
+
+      - description: Support for Servant 0.12
+        issue: none
+        authors: phadej
+        date: 2017-11-07
+
+      - description: Support for Servant 0.11
+        issue: none
+        pr: 32
+        authors: adinapoli-iohk
+        date: 2017-10-18
+        notes: Includes 0-weighted instance for EmptyAPI
+
+  - version: "0.0.3.0"
+    changes:
+
+      - description: Add jsonEquality
+        issue: 2
+        pr: 30
+        authors: erewok
+        date: 2017-10-15
+
+      - description: Support hspec >= 2.4
+        issue: 27
+        pr: 29
+        authors: erewok, jkarni
+        date: 2017-10-15
+
+  - version: "0.0.2.4"
+    changes:
+
+      - description: Don't append slashes to paths
+        issue: 22
+        authors: declension
+        date: 2017-03-11
+
+  - version: "0.0.2.3"
+    changes:
+
+      - description: Fix QueryParam and QueryFlag requests
+        issue: 23
+        authors: declension
+        date: 2017-03-10
+
+  - version: "0.0.2.2"
+    changes:
+
+      - description: Make onlyJsonObjects succeed in non-JSON endpoints
+        issue: 20
+        authors: jkarni
+        date: 2016-10-18
+
+
+  - version: "0.0.2.1"
+    changes:
+
+      - description: Add notLongerThan predicate
+        pr: 17
+        authors: jkarni
+        date: 2016-10-05
+
+      - description: Add getsHaveLastModifiedHeader predicate
+        pr: none
+        authors: jkarni
+        date: 2016-10-03
+
+      - description: Raise upper bounds
+        notes: >
+            For Quickcheck, aeson, http-client, servant, servant-client and
+            servant-server.
+        pr: none
+        authors: jkarni
+        date: 2016-10-03
+

  - version: "0.0.2.0"
    changes:
--- a/cabal.haskell-ci
+++ b/cabal.haskell-ci
@ -0,0 +1,7 @@
+branches: master
+
+constraint-set base-compat-0.10
+  constraints: base-compat ==0.10.*
+
+constraint-set base-compat-0.11
+  constraints: base-compat ==0.11.*
--- a/cabal.project
+++ b/cabal.project
@ -0,0 +1,4 @@
+packages: .
+tests: true
+
+allow-newer: servant-blaze:servant
--- a/example/Main.hs
+++ b/example/Main.hs
@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings, DataKinds #-}
+module Main (main) where
+
+import Servant
+import Servant.QuickCheck
+import Test.Hspec
+import Data.Text (Text)
+import System.Environment (getArgs)
+
+main :: IO ()
+main = do
+    args <- getArgs
+    case args of
+        [] -> putStrLn "Not running without arguments. Try --help or --fail-fast."
+        _  -> hspec spec
+
+-- Change to String to reproduce
+-- https://github.com/haskell-servant/servant-quickcheck/issues/41
+type API = Get '[PlainText] Text
+
+api :: Proxy API
+api = Proxy
+
+server :: Server API
+server = return "Sigurð Fáfnirslayer"
+
+spec :: Spec
+spec = describe "example server" $
+    it "mangles UTF-8 in error messages" $
+        withServantServer api (return server) $ \burl ->
+            serverSatisfies api burl defaultArgs (getsHaveCacheControlHeader <%> mempty)
--- a/servant-quickcheck.cabal
+++ b/servant-quickcheck.cabal
@ -1,22 +1,22 @@
-name:                servant-quickcheck
-version:             0.0.2.0
-synopsis:            QuickCheck entire APIs
+name:               servant-quickcheck
+version:            0.0.9.1
+synopsis:           QuickCheck entire APIs
 description:
- This packages provides QuickCheck properties that are tested across an entire
- API.
+  This packages provides QuickCheck properties that are tested across an entire
+  API.

-license:             BSD3
-license-file:        LICENSE
-author:              Julian K. Arni
-maintainer:          jkarni@gmail.com
-category:            Web
-build-type:          Simple
-cabal-version:       >=1.10
-extra-source-files:
-  CHANGELOG.yaml
+license:            BSD3
+license-file:       LICENSE
+author:             Julian K. Arni
+maintainer:         jkarni@gmail.com
+category:           Web
+build-type:         Simple
+cabal-version:      >=1.10
+extra-source-files: CHANGELOG.yaml
+tested-with:        GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3

 source-repository head
-  type: git
+  type:     git
  location: https://github.com/haskell-servant/servant-quickcheck

 flag long-tests
@ -24,82 +24,115 @@ flag long-tests
  default:     False

 library
-  exposed-modules:     Servant.QuickCheck
-                     , Servant.QuickCheck.Internal
-                     , Servant.QuickCheck.Internal.Predicates
-                     , Servant.QuickCheck.Internal.HasGenRequest
-                     , Servant.QuickCheck.Internal.QuickCheck
-                     , Servant.QuickCheck.Internal.Equality
-                     , Servant.QuickCheck.Internal.ErrorTypes
-  build-depends:       base >=4.8 && <4.10
-                     , base-compat == 0.9.*
-                     , aeson > 0.8 && < 0.12
-                     , bytestring == 0.10.*
-                     , case-insensitive == 1.2.*
-                     , data-default-class >= 0.0 && < 0.2
-                     , hspec == 2.2.*
-                     , http-client >= 0.4.30 && < 0.5
-                     , http-media == 0.6.*
-                     , http-types > 0.8 && < 0.10
-                     , mtl > 2.1 && < 2.3
-                     , pretty == 1.1.*
-                     , process >= 1.2 && < 1.5
-                     , QuickCheck > 2.7 && < 2.9
-                     , servant > 0.6 && < 0.9
-                     , servant-client > 0.6 && < 0.9
-                     , servant-server > 0.6 && < 0.9
-                     , split == 0.2.*
-                     , string-conversions > 0.3 && < 0.5
-                     , temporary == 1.2.*
-                     , text == 1.*
-                     , warp >= 3.2.4 && < 3.3
+  exposed-modules:
+    Servant.QuickCheck
+    Servant.QuickCheck.Internal
+    Servant.QuickCheck.Internal.Equality
+    Servant.QuickCheck.Internal.ErrorTypes
+    Servant.QuickCheck.Internal.HasGenRequest
+    Servant.QuickCheck.Internal.Predicates
+    Servant.QuickCheck.Internal.QuickCheck

-  hs-source-dirs:      src
-  default-extensions:  TypeOperators
-                     , FlexibleInstances
-                     , FlexibleContexts
-                     , DataKinds
-                     , GADTs
-                     , MultiParamTypeClasses
-                     , DeriveFunctor
-                     , KindSignatures
-                     , RankNTypes
-                     , ConstraintKinds
-                     , DeriveGeneric
-                     , ScopedTypeVariables
-                     , OverloadedStrings
-                     , FunctionalDependencies
-                     , NoImplicitPrelude
-                     , DeriveDataTypeable
-  default-language:    Haskell2010
+  build-depends:
+      aeson                  >=0.8    && <2
+    , base                   >=4.9    && <4.15
+    , base-compat-batteries  >=0.10.1 && <0.12
+    , bytestring             >=0.10   && <0.11
+    , case-insensitive       >=1.2    && <1.3
+    , clock                  >=0.7    && <0.9
+    , data-default-class     >=0.0    && <0.2
+    , hspec                  >=2.5.6  && <2.8
+    , http-client            >=0.4.30 && <0.8
+    , http-media             >=0.6    && <0.9
+    , http-types             >=0.8    && <0.13
+    , mtl                    >=2.1    && <2.3
+    , pretty                 >=1.1    && <1.2
+    , process                >=1.2    && <1.7
+    , QuickCheck             >=2.7    && <2.15
+    , servant                >=0.17   && <0.19
+    , servant-client         >=0.17   && <0.19
+    , servant-server         >=0.17   && <0.19
+    , split                  >=0.2    && <0.3
+    , string-conversions     >=0.3    && <0.5
+    , temporary              >=1.2    && <1.4
+    , text                   >=1      && <2
+    , time                   >=1.5    && <1.11
+    , warp                   >=3.2.4  && <3.4
+
+  if !impl(ghc >=8.0)
+    build-depends: semigroups >=0.18.3 && <0.20
+
+  hs-source-dirs:     src
+  default-extensions:
+    NoImplicitPrelude
+    ConstraintKinds
+    DataKinds
+    DeriveDataTypeable
+    DeriveFunctor
+    DeriveGeneric
+    FlexibleContexts
+    FlexibleInstances
+    FunctionalDependencies
+    GADTs
+    KindSignatures
+    MultiParamTypeClasses
+    OverloadedStrings
+    RankNTypes
+    ScopedTypeVariables
+    TypeOperators
+
+  default-language:   Haskell2010

 test-suite spec
-  type:                exitcode-stdio-1.0
-  ghc-options:         -Wall -threaded
-  default-language:    Haskell2010
-  hs-source-dirs:      test
-  main-is:             Spec.hs
-  other-modules:       Servant.QuickCheck.InternalSpec
-  build-depends:       base == 4.*
-                     , base-compat
-                     , servant-quickcheck
-                     , hspec
-                     , hspec-core
-                     , http-client
-                     , warp
-                     , servant-server
-                     , servant-client
-                     , servant
-                     , transformers
-                     , QuickCheck
-                     , quickcheck-io
-  default-extensions:  TypeOperators
-                     , FlexibleInstances
-                     , FlexibleContexts
-                     , GADTs
-                     , DataKinds
-                     , NoImplicitPrelude
-                     , OverloadedStrings
-                     , ScopedTypeVariables
+  type:               exitcode-stdio-1.0
+  ghc-options:        -Wall -threaded
+  default-language:   Haskell2010
+  hs-source-dirs:     test
+  main-is:            Spec.hs
+  other-modules:      Servant.QuickCheck.InternalSpec
+  build-tool-depends: hspec-discover:hspec-discover -any
+  build-depends:
+      aeson
+    , base
+    , base-compat-batteries
+    , blaze-html
+    , bytestring
+    , hspec
+    , hspec-core             >=2.5.5 && <2.8
+    , http-client
+    , QuickCheck
+    , quickcheck-io
+    , servant
+    , servant-blaze
+    , servant-client
+    , servant-quickcheck
+    , servant-server
+    , transformers
+    , warp
+
+  default-extensions:
+    NoImplicitPrelude
+    DataKinds
+    FlexibleContexts
+    FlexibleInstances
+    GADTs
+    OverloadedStrings
+    ScopedTypeVariables
+    TypeOperators
+
  if flag(long-tests)
-      cpp-options: -DLONG_TESTS
+    cpp-options: -DLONG_TESTS
+
+test-suite example
+  type:             exitcode-stdio-1.0
+  main-is:          Main.hs
+  hs-source-dirs:   example
+  ghc-options:      -Wall
+  build-depends:
+      base
+    , hspec
+    , servant-quickcheck
+    , servant-server
+    , text
+
+  default-language: Haskell2010
--- a/src/Servant/QuickCheck.hs
+++ b/src/Servant/QuickCheck.hs
@ -27,12 +27,18 @@ module Servant.QuickCheck
  -- in RFCs. The __Best Practices__ includes, in addition to RFC
  -- recommendations, recommendations found elsewhere or generally accepted.
  , not500
+  , notLongerThan
  , onlyJsonObjects
+  , honoursAcceptHeader
  , notAllowedContainsAllowHeader
  , unauthorizedContainsWWWAuthenticate
+  , getsHaveLastModifiedHeader
  , getsHaveCacheControlHeader
  , headsHaveCacheControlHeader
  , createContainsValidLocation
+    -- * Html Predicates
+  , htmlIncludesDoctype
+
  -- *** Predicate utilities and types
  , (<%>)
  , Predicates
@ -48,6 +54,7 @@ module Servant.QuickCheck
  -- represents other means of checking equality
  -- *** Useful @ResponseEquality@s
  , bodyEquality
+  , jsonEquality
  , allEquality
  -- ** Response equality type
  , ResponseEquality(..)
--- a/src/Servant/QuickCheck/Internal/Equality.hs
+++ b/src/Servant/QuickCheck/Internal/Equality.hs
@ -1,16 +1,23 @@
 module Servant.QuickCheck.Internal.Equality where

+import Data.Aeson          (Value, decode, decodeStrict)
+import Data.ByteString     (ByteString)
+import qualified Data.ByteString.Lazy as LB
 import Data.Function       (on)
 import Network.HTTP.Client (Response, responseBody)
+import Data.Semigroup      (Semigroup (..))
 import Prelude.Compat

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

+instance Semigroup (ResponseEquality b) where
+  ResponseEquality a <> ResponseEquality b = ResponseEquality $ \x y ->
+    a x y && b x y  
+
 instance Monoid (ResponseEquality b) where
  mempty = ResponseEquality $ \_ _ -> True
-  ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->
-    a x y && b x y
+  mappend = (<>)

 -- | Use `Eq` instance for `Response`
 --
@ -23,3 +30,29 @@ allEquality = ResponseEquality (==)
 -- /Since 0.0.0.0/
 bodyEquality :: Eq b => ResponseEquality b
 bodyEquality = ResponseEquality ((==) `on` responseBody)
+
+-- | Equality as 'Value'. This means that if two bodies are equal as JSON
+-- (e.g., insignificant whitespace difference) they are considered equal.
+--
+-- /Since 0.0.3.0/
+jsonEquality :: (JsonEq b) => ResponseEquality b
+jsonEquality = ResponseEquality (jsonEq `on` responseBody)
+
+class JsonEq a where
+  decode' :: a -> Maybe Value
+  jsonEq :: a -> a -> Bool
+  jsonEq first second = compareDecodedResponses (decode' first) (decode' second)
+
+instance JsonEq LB.ByteString where
+  decode' = decode
+
+instance JsonEq ByteString where
+  decode' = decodeStrict
+
+compareDecodedResponses :: Maybe Value -> Maybe Value -> Bool
+compareDecodedResponses resp1 resp2 =
+  case resp1 of
+    Nothing -> False  -- if decoding fails we assume failure
+    (Just r1) -> case resp2 of
+      Nothing -> False  -- another decode failure
+      (Just r2) -> r1 == r2
--- a/src/Servant/QuickCheck/Internal/ErrorTypes.hs
+++ b/src/Servant/QuickCheck/Internal/ErrorTypes.hs
@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Servant.QuickCheck.Internal.ErrorTypes where

 import           Control.Exception       (Exception (..))
@ -8,9 +9,10 @@ import           Data.Typeable           (Typeable)
 import           GHC.Generics            (Generic)
 import qualified Network.HTTP.Client     as C
 import           Network.HTTP.Types      (Header, statusCode)
-import           Prelude.Compat
 import           Text.PrettyPrint

+import           Prelude.Compat hiding ((<>))
+
 data PredicateFailure
  = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
  deriving (Typeable, Generic)
--- a/src/Servant/QuickCheck/Internal/HasGenRequest.hs
+++ b/src/Servant/QuickCheck/Internal/HasGenRequest.hs
@ -2,112 +2,147 @@
 {-# LANGUAGE PolyKinds #-}
 module Servant.QuickCheck.Internal.HasGenRequest where

-import Data.Default.Class       (def)
-import Data.Monoid              ((<>))
 import Data.String              (fromString)
 import Data.String.Conversions  (cs)
-import qualified Data.ByteString as BS
 import GHC.TypeLits             (KnownSymbol, Nat, symbolVal)
 import Network.HTTP.Client      (Request, RequestBody (..), host, method, path,
                                 port, queryString, requestBody, requestHeaders,
-                                 secure)
+                                 secure, defaultRequest)
 import Network.HTTP.Media       (renderHeader)
 import Prelude.Compat
 import Servant
 import Servant.API.ContentTypes (AllMimeRender (..))
 import Servant.Client           (BaseUrl (..), Scheme (..))
-import Test.QuickCheck          (Arbitrary (..), Gen, elements, oneof)
+import Test.QuickCheck          (Arbitrary (..), Gen, elements, frequency)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Internal as BS (c2w)


+-- -----------------------------------------------------------------------------
+-- runGenRequest
+
+-- | This function returns a QuickCheck `Gen a` when passed a servant API value,
+-- typically a `Proxy API`. The generator returned is a function
+-- that accepts a `BaseUrl` and returns a `Request`, which can then be used
+-- to issue network requests. This `Gen` type makes it easier to compare distinct
+-- APIs across different `BaseUrl`s.
+runGenRequest :: HasGenRequest a => Proxy a -> Gen (BaseUrl -> Request)
+runGenRequest = snd . genRequest
+
+
+-- -----------------------------------------------------------------------------
+-- HasGenRequest
+
+-- | This is the core Servant-Quickcheck generator, which, when given a `Proxy API`
+-- will return a pair of `Int` and `Gen a`, where `a` is a function from
+-- `BaseUrl` to a `Network.Http.Client.Request`. The `Int` is a weight for the
+-- QuickCheck `frequency` function which ensures a random distribution across
+-- all endpoints in an API.
 class HasGenRequest a where
-    genRequest :: Proxy a -> Gen (BaseUrl -> Request)
+    genRequest :: Proxy a -> (Int, Gen (BaseUrl -> Request))
+

 instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
    genRequest _
-      = oneof [ genRequest (Proxy :: Proxy a)
-              , genRequest (Proxy :: Proxy b)
-              ]
+      = (lf + rf, frequency [l, r])
+      where
+        l@(lf, _) = genRequest (Proxy :: Proxy a)
+        r@(rf, _) = genRequest (Proxy :: Proxy b)
+

 instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
      old' <- old
-      return $ \burl -> let r = old' burl in r { path = new <> path r }
+      return $ \burl -> let r = old' burl
+                            oldPath = path r
+                            oldPath' = BS.dropWhile (== BS.c2w '/') oldPath
+                            paths = filter (not . BS.null) [new, oldPath']
+                            in r { path = "/" <> BS.intercalate "/" paths })
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        new = cs $ symbolVal (Proxy :: Proxy path)

+instance HasGenRequest EmptyAPI where
+  genRequest _ = (0, error "EmptyAPIs cannot be queried.")
+
+instance HasGenRequest api => HasGenRequest (Summary d :> api) where
+  genRequest _ = genRequest (Proxy :: Proxy api)
+
+instance HasGenRequest api => HasGenRequest (Description d :> api) where
+  genRequest _ = genRequest (Proxy :: Proxy api)
+
 instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
-    => HasGenRequest (Capture x c :> b) where
-    genRequest _ = do
+    => HasGenRequest (Capture' mods x c :> b) where
+    genRequest _ = (oldf, do
      old' <- old
      new' <- toUrlPiece <$> new
-      return $ \burl -> let r = old' burl in r { path = cs new' <> path r }
+      return $ \burl -> let r = old' burl in r { path = cs new' <> path r })
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        new = arbitrary :: Gen c

-#if MIN_VERSION_servant(0,8,0)
 instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
    => HasGenRequest (CaptureAll x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
      old' <- old
      new' <- fmap (cs . toUrlPiece) <$> new
      let new'' = BS.intercalate "/" new'
-      return $ \burl -> let r = old' burl in r { path = new'' <> path r }
+      return $ \burl -> let r = old' burl in r { path = new'' <> path r })
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        new = arbitrary :: Gen [c]
-#endif

 instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
-    => HasGenRequest (Header h c :> b) where
-    genRequest _ = do
+    => HasGenRequest (Header' mods h c :> b) where
+    genRequest _ = (oldf, do
      old' <- old
-      new' <- toUrlPiece <$> new
+      new' <- toUrlPiece <$> new  -- TODO: generate lenient or/and optional
      return $ \burl -> let r = old' burl in r {
-          requestHeaders = (hdr, cs new') : requestHeaders r }
+          requestHeaders = (hdr, cs new') : requestHeaders r })
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        hdr = fromString $ symbolVal (Proxy :: Proxy h)
        new = arbitrary :: Gen c

 instance (AllMimeRender x c, Arbitrary c, HasGenRequest b)
-    => HasGenRequest (ReqBody x c :> b) where
-    genRequest _ = do
-      old' <- old
+    => HasGenRequest (ReqBody' mods x c :> b) where
+    genRequest _ = (oldf, do
+      old' <- old  -- TODO: generate lenient
      new' <- new
      (ct, bd) <- elements $ allMimeRender (Proxy :: Proxy x) new'
      return $ \burl -> let r = old' burl in r {
          requestBody = RequestBodyLBS bd
        , requestHeaders = ("Content-Type", renderHeader ct) : requestHeaders r
-        }
+        })
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        new = arbitrary :: Gen c

 instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
-    => HasGenRequest (QueryParam x c :> b) where
-    genRequest _ = do
-      new' <- new
+    => HasGenRequest (QueryParam' mods x c :> b) where
+    genRequest _ = (oldf, do
+      new' <- new  -- TODO: generate lenient or/and optional
      old' <- old
-      return $ \burl -> let r = old' burl in r {
-          queryString = queryString r
-                     <> param <> "=" <> cs (toQueryParam new') }
+      return $ \burl -> let r = old' burl
+                            newExpr = param <> "=" <> cs (toQueryParam new')
+                            qs = queryString r in r {
+          queryString = if BS.null qs then newExpr else newExpr <> "&" <> qs })
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        param = cs $ symbolVal (Proxy :: Proxy x)
        new = arbitrary :: Gen c

 instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
    => HasGenRequest (QueryParams x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
      new' <- new
      old' <- old
      return $ \burl -> let r = old' burl in r {
          queryString = queryString r
-                     <> if length new' > 0 then fold (toParam <$> new') else ""}
+                     <> if length new' > 0 then fold (toParam <$> new') else ""})
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        param = cs $ symbolVal (Proxy :: Proxy x)
        new = arbitrary :: Gen [c]
        toParam c = param <> "[]=" <> cs (toQueryParam c)
@ -115,22 +150,32 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)

 instance (KnownSymbol x, HasGenRequest b)
    => HasGenRequest (QueryFlag x :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
      old' <- old
-      return $ \burl -> let r = old' burl in r {
-          queryString = queryString r <> param <> "=" }
+      return $ \burl -> let r = old' burl
+                            qs = queryString r in r {
+          queryString = if BS.null qs then param else param <> "&" <> qs })
      where
-        old = genRequest (Proxy :: Proxy b)
+        (oldf, old) = genRequest (Proxy :: Proxy b)
        param = cs $ symbolVal (Proxy :: Proxy x)

 instance (ReflectMethod method)
    => HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
-    genRequest _ = return $ \burl -> def
+    genRequest _ = (1, return $ \burl -> defaultRequest
       { host = cs $ baseUrlHost burl
       , port = baseUrlPort burl
       , secure = baseUrlScheme burl == Https
       , method = reflectMethod (Proxy :: Proxy method)
-       }
+       })
+
+instance (ReflectMethod method)
+    => HasGenRequest (NoContentVerb (method :: k)) where
+    genRequest _ = (1, return $ \burl -> defaultRequest
+       { host = cs $ baseUrlHost burl
+       , port = baseUrlPort burl
+       , secure = baseUrlScheme burl == Https
+       , method = reflectMethod (Proxy :: Proxy method)
+       })

 instance (HasGenRequest a) => HasGenRequest (RemoteHost :> a) where
    genRequest _ = genRequest (Proxy :: Proxy a)
--- a/src/Servant/QuickCheck/Internal/Predicates.hs
+++ b/src/Servant/QuickCheck/Internal/Predicates.hs
@ -1,26 +1,33 @@
 module Servant.QuickCheck.Internal.Predicates where

 import           Control.Exception     (catch, throw)
-import           Control.Monad         (when, unless, liftM2)
+import           Control.Monad         (liftM2, unless, when)
 import           Data.Aeson            (Object, decode)
+import           Data.Bifunctor        (first)
 import qualified Data.ByteString       as SBS
 import qualified Data.ByteString.Char8 as SBSC
 import qualified Data.ByteString.Lazy  as LBS
-import           Data.CaseInsensitive  (mk)
+import           Data.CaseInsensitive  (foldCase, foldedCase, mk)
 import           Data.Either           (isRight)
 import           Data.List.Split       (wordsBy)
 import           Data.Maybe            (fromMaybe, isJust)
-import           Data.Monoid           ((<>))
+import           Data.Semigroup        (Semigroup (..))
+import qualified Data.Text             as T
+import           Data.Time             (UTCTime, defaultTimeLocale, parseTimeM,
+                                        rfc822DateFormat)
 import           GHC.Generics          (Generic)
 import           Network.HTTP.Client   (Manager, Request, Response, httpLbs,
-                                        method, requestHeaders, responseBody,
-                                        responseHeaders, parseRequest, responseStatus)
+                                        method, parseRequest, requestHeaders,
+                                        responseBody, responseHeaders,
+                                        responseStatus)
 import           Network.HTTP.Media    (matchAccept)
 import           Network.HTTP.Types    (methodGet, methodHead, parseMethod,
                                        renderStdMethod, status100, status200,
                                        status201, status300, status401,
                                        status405, status500)
 import           Prelude.Compat
+import           System.Clock          (Clock (Monotonic), diffTimeSpec,
+                                        getTime, toNanoSecs)

 import Servant.QuickCheck.Internal.ErrorTypes

@ -36,7 +43,23 @@ import Servant.QuickCheck.Internal.ErrorTypes
 -- /Since 0.0.0.0/
 not500 :: ResponsePredicate
 not500 = ResponsePredicate $ \resp ->
-  when (responseStatus resp == status500) $ fail "not500"
+  when (responseStatus resp == status500) $ throw $ PredicateFailure "not500" Nothing resp
+
+-- | [__Optional__]
+--
+-- This function checks that the response from the server does not take longer
+-- than the specified number of nanoseconds.
+--
+-- /Since 0.0.2.1/
+notLongerThan :: Integer -> RequestPredicate
+notLongerThan maxAllowed
+  = RequestPredicate $ \req mgr -> do
+     start <- getTime Monotonic
+     resp <- httpLbs req mgr
+     end <- getTime Monotonic
+     when (toNanoSecs (end `diffTimeSpec` start) > maxAllowed) $
+       throw $ PredicateFailure "notLongerThan" (Just req) resp
+     return []

 -- | [__Best Practice__]
 --
@ -61,9 +84,13 @@ not500 = ResponsePredicate $ \resp ->
 -- /Since 0.0.0.0/
 onlyJsonObjects :: ResponsePredicate
 onlyJsonObjects
-  = ResponsePredicate (\resp -> case decode (responseBody resp) of
-      Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
-      Just (_ :: Object) -> return ())
+  = ResponsePredicate (\resp -> do
+    case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
+      Nothing    -> return ()
+      Just ctype -> when ("application/json" `SBS.isPrefixOf` ctype) $ do
+        case (decode (responseBody resp) :: Maybe Object) of
+          Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
+          Just _  -> return ())

 -- | __Optional__
 --
@ -91,21 +118,52 @@ createContainsValidLocation
     resp <- httpLbs req mgr
     if responseStatus resp == status201
         then case lookup "Location" $ responseHeaders resp of
-             Nothing -> fail n
+             Nothing -> throw $ PredicateFailure n (Just req) resp
             Just l  -> case parseRequest $ SBSC.unpack l of
-               Nothing -> fail n
+               Nothing -> throw $ PredicateFailure n (Just req) resp
               Just x  -> do
                 resp2 <- httpLbs x mgr
-                 status2XX resp2 n
+                 status2XX (Just req) resp2 n
                 return [resp, resp2]
         else return [resp]

-{-
-getsHaveLastModifiedHeader :: ResponsePredicate
+-- | [__Optional__]
+--
+-- The @Last-Modified@ header represents the time a resource was last
+-- modified. It is used to drive caching and conditional requests.
+--
+-- When using this mechanism, the server adds the @Last-Modified@ header to
+-- responses. Clients may then make requests with the @If-Modified-Since@
+-- header to conditionally request resources. If the resource has not
+-- changed since that date, the server responds with a status code of 304
+-- (@Not Modified@) without a response body.
+--
+-- The @Last-Modified@ header can also be used in conjunction with the
+-- @If-Unmodified-Since@ header to drive optimistic concurrency.
+--
+-- The @Last-Modified@ date must be in RFC 822 format.
+--
+-- __References__:
+--
+--   * 304 Not Modified: <https://tools.ietf.org/html/rfc7232#section-4.1 RFC 7232 Section 4.1>
+--   * Last-Modified header: <https://tools.ietf.org/html/rfc7232#section-2.2 RFC 7232 Section 2.2>
+--   * If-Modified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.3 RFC 7232 Section 3.3>
+--   * If-Unmodified-Since header: <https://tools.ietf.org/html/rfc7232#section-3.4 RFC 7232 Section 3.4>
+--   * Date format: <https://tools.ietf.org/html/rfc2616#section-3.3 RFC 2616 Section 3.3>
+--
+-- /Since 0.0.2.1/
+getsHaveLastModifiedHeader :: RequestPredicate
 getsHaveLastModifiedHeader
-  = ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
+  = RequestPredicate $ \req mgr ->
+     if (method req == methodGet)
+      then do
+        resp <- httpLbs req mgr
+        unless (hasValidHeader "Last-Modified" isRFC822Date resp) $ do
+          throw $ PredicateFailure "getsHaveLastModifiedHeader" (Just req) resp
+        return [resp]
+      else return []
+

-}

 -- | [__RFC Compliance__]
 --
@ -117,23 +175,27 @@ getsHaveLastModifiedHeader
 -- This function checks that every @405 Method Not Allowed@ response contains
 -- an @Allow@ header with a list of standard HTTP methods.
 --
+-- Note that 'servant' itself does not currently set the @Allow@ headers.
+--
 -- __References__:
 --
 --   * @Allow@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.7>
 --   * Status 405: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html RFC 2616 Section 10.4.6>
+--   * Servant Allow header issue: <https://github.com/haskell-servant/servant/issues/489 Issue #489>
 --
 -- /Since 0.0.0.0/
 notAllowedContainsAllowHeader :: RequestPredicate
 notAllowedContainsAllowHeader
  = RequestPredicate $ \req mgr -> do
-      resp <- mapM (flip httpLbs mgr) $ [ req { method = renderStdMethod m }
-                                        | m <- [minBound .. maxBound ]
-                                        , renderStdMethod m /= method req ]
-      case filter pred' resp of
-        (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
+      let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
+                                                      , renderStdMethod m /= method req ]
+      resp <- mapM (flip httpLbs mgr) reqs
+
+      case filter pred' (zip reqs resp) of
+        (x:_) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just $ fst x) (snd x)
        []     -> return resp
    where
-      pred' resp = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
+      pred' (_, resp) = responseStatus resp == status405 && not (hasValidHeader "Allow" go resp)
        where
          go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
               $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
@ -163,7 +225,7 @@ honoursAcceptHeader
          sacc  = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
      if status100 < scode && scode < status300
        then if isJust $ sctype >>= \x -> matchAccept [x] sacc
-          then fail "honoursAcceptHeader"
+          then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
          else return [resp]
        else return [resp]

@ -274,7 +336,29 @@ unauthorizedContainsWWWAuthenticate
  = ResponsePredicate $ \resp ->
      if responseStatus resp == status401
        then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
-          fail "unauthorizedContainsWWWAuthenticate"
+          throw $ PredicateFailure "unauthorizedContainsWWWAuthenticate" Nothing resp
+        else return ()
+
+
+-- | [__RFC Compliance__]
+--
+-- [An HTML] document will start with exactly this string: <!DOCTYPE html>
+--
+-- This function checks that HTML documents (those with `Content-Type: text/html...`)
+-- include a DOCTYPE declaration at the top. We do not enforce capital case for the string `DOCTYPE`.
+--
+-- __References__:
+--
+--  * HTML5 Doctype: <https://tools.ietf.org/html/rfc7992#section-6.1 RFC 7992 Section 6.1>
+-- /Since 0.3.0.0/
+htmlIncludesDoctype :: ResponsePredicate
+htmlIncludesDoctype
+  = ResponsePredicate $ \resp ->
+      if hasValidHeader "Content-Type" (SBS.isPrefixOf . foldCase $ "text/html") resp
+        then do
+            let htmlContent = foldCase . LBS.take 20 $ responseBody resp
+            unless (LBS.isPrefixOf (foldCase "<!doctype html>") htmlContent) $
+              throw $ PredicateFailure "htmlIncludesDoctype" Nothing resp
        else return ()

 -- * Predicate logic
@ -288,37 +372,47 @@ unauthorizedContainsWWWAuthenticate
 -- | A predicate that depends only on the response.
 --
 -- /Since 0.0.0.0/
-data ResponsePredicate = ResponsePredicate
+newtype ResponsePredicate = ResponsePredicate
  { getResponsePredicate :: Response LBS.ByteString -> IO ()
  } deriving (Generic)

+instance Semigroup ResponsePredicate where
+  ResponsePredicate a <> ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
+
 instance Monoid ResponsePredicate where
  mempty = ResponsePredicate $ const $ return ()
-  ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
+  mappend = (<>)

 -- | A predicate that depends on both the request and the response.
 --
 -- /Since 0.0.0.0/
-data RequestPredicate = RequestPredicate
-  { getRequestPredicate    :: Request -> Manager -> IO [Response LBS.ByteString]
+newtype RequestPredicate = RequestPredicate
+  { getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
  } deriving (Generic)

 -- TODO: This isn't actually a monoid
 instance Monoid RequestPredicate where
  mempty = RequestPredicate (\r m -> httpLbs r m >>= \x -> return ([x]))
-  RequestPredicate a `mappend` RequestPredicate b = RequestPredicate $ \r mgr ->
+  mappend = (<>)
+
+-- TODO: This isn't actually a monoid
+instance Semigroup RequestPredicate where
+  RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
    liftM2 (<>) (a r mgr) (b r mgr)

 -- | A set of predicates. Construct one with 'mempty' and '<%>'.
 data Predicates = Predicates
-  { requestPredicates :: RequestPredicate
+  { requestPredicates  :: RequestPredicate
  , responsePredicates :: ResponsePredicate
  } deriving (Generic)

+instance Semigroup Predicates where
+  a <> b = Predicates (requestPredicates a <> requestPredicates b)
+                      (responsePredicates a <> responsePredicates b)
+
 instance Monoid Predicates where
  mempty = Predicates mempty mempty
-  a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
-                             (responsePredicates a <> responsePredicates b)
+  mappend = (<>)

 class JoinPreds a where
  joinPreds :: a -> Predicates -> Predicates
@ -354,8 +448,14 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
  Nothing -> False
  Just v  -> p v

-status2XX :: Monad m => Response b -> String -> m ()
-status2XX r t
-  | status200 <= responseStatus r && responseStatus r < status300
+isRFC822Date :: SBS.ByteString -> Bool
+isRFC822Date s
+  = case parseTimeM True defaultTimeLocale rfc822DateFormat (SBSC.unpack s) of
+    Nothing -> False
+    Just (_ :: UTCTime) -> True
+
+status2XX :: Monad m => Maybe Request -> Response LBS.ByteString -> T.Text -> m ()
+status2XX mreq resp t
+  | status200 <= responseStatus resp && responseStatus resp < status300
  = return ()
-  | otherwise = fail t
+  | otherwise = throw $ PredicateFailure t mreq resp
--- a/src/Servant/QuickCheck/Internal/QuickCheck.hs
+++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs
@ -1,7 +1,8 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
 module Servant.QuickCheck.Internal.QuickCheck where

-import           Control.Concurrent       (modifyMVar_, newMVar, readMVar)
+import           Control.Concurrent       (tryReadMVar, newEmptyMVar, tryPutMVar)
 import           Control.Monad            (unless)
 import qualified Data.ByteString.Lazy     as LBS
 import           Data.Proxy               (Proxy)
@ -10,11 +11,13 @@ import           Network.Wai.Handler.Warp (withApplication)
 import           Prelude.Compat
 import           Servant                  (Context (EmptyContext), HasServer,
                                           Server, serveWithContext)
+#if MIN_VERSION_servant_server(0,18,0)
+import           Servant                  (DefaultErrorFormatters, ErrorFormatters, HasContextEntry, type (.++))
+#endif
 import           Servant.Client           (BaseUrl (..), Scheme (..))
 import           System.IO.Unsafe         (unsafePerformIO)
 import           Test.Hspec               (Expectation, expectationFailure)
-import           Test.QuickCheck          (Args (..), Result (..),
-                                           quickCheckWithResult)
+import           Test.QuickCheck          (Args (..),  Result (..), quickCheckWithResult)
 import           Test.QuickCheck.Monadic  (assert, forAllM, monadicIO, monitor,
                                           run)
 import           Test.QuickCheck.Property (counterexample)
@ -37,7 +40,11 @@ withServantServer api = withServantServerAndContext api EmptyContext
 -- application.
 --
 -- /Since 0.0.0.0/
+#if MIN_VERSION_servant_server(0,18,0)
+withServantServerAndContext :: (HasServer a ctx, HasContextEntry (ctx .++ DefaultErrorFormatters) ErrorFormatters)
+#else
 withServantServerAndContext :: HasServer a ctx
+#endif
  => Proxy a -> Context ctx -> IO (Server a) -> (BaseUrl -> IO r) -> IO r
 withServantServerAndContext api ctx server t
  = withApplication (return . serveWithContext api ctx =<< server) $ \port ->
@ -70,25 +77,32 @@ withServantServerAndContext api ctx server t
 serversEqual :: HasGenRequest a =>
  Proxy a -> BaseUrl -> BaseUrl -> Args -> ResponseEquality LBS.ByteString -> Expectation
 serversEqual api burl1 burl2 args req = do
-  let reqs = (\f -> (f burl1, f burl2)) <$> genRequest api
+  let reqs = (\f -> (f burl1, f burl2)) <$> runGenRequest api
  -- This MVar stuff is clunky! But there doesn't seem to be an easy way to
  -- return results when a test fails, since an exception is throw.
-  deetsMVar <- newMVar $ error "should not be called"
+  deetsMVar <- newEmptyMVar
  r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \(req1, req2) -> do
    resp1 <- run $ C.httpLbs (noCheckStatus req1) defManager
    resp2 <- run $ C.httpLbs (noCheckStatus req2) defManager
    unless (getResponseEquality req resp1 resp2) $ do
      monitor (counterexample "hi" )
-      run $ modifyMVar_ deetsMVar $ const $ return $
-        ServerEqualityFailure req1 resp1 resp2
+      _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
      assert False
  case r of
    Success {} -> return ()
-    Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
-      "Failed:\n" ++ show x
+    Failure{..} -> do
+      mx <- tryReadMVar deetsMVar
+      case mx of
+        Just x ->
+          expectationFailure $ "Failed:\n" ++ show x
+        Nothing ->
+          expectationFailure $ "We failed to record a reason for failure: " <> show r
    GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
-    NoExpectedFailure {} -> expectationFailure $ "No expected failure"
-    InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
+    NoExpectedFailure {} -> expectationFailure "No expected failure"
+#if MIN_VERSION_QuickCheck(2,12,0)
+#else
+    InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
+#endif

 -- | Check that a server satisfies the set of properties specified.
 --
@ -111,40 +125,68 @@ serversEqual api burl1 burl2 args req = do
 -- /Since 0.0.0.0/
 serverSatisfies :: (HasGenRequest a) =>
  Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
-serverSatisfies api burl args preds = do
-  let reqs = ($ burl) <$> genRequest api
-  deetsMVar <- newMVar $ error "should not be called"
+serverSatisfies api =  serverSatisfiesMgr api defManager
+
+-- | Check that a server satisfies the set of properties specified, and
+-- accept a 'Manager' for running the HTTP requests through.
+--
+-- See 'serverSatisfies' for more details.
+--
+-- @since 0.0.7.2
+serverSatisfiesMgr :: (HasGenRequest a) =>
+  Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
+serverSatisfiesMgr api manager burl args preds = do
+  let reqs = ($ burl) <$> runGenRequest api
+  deetsMVar <- newEmptyMVar
  r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
-     v <- run $ finishPredicates preds (noCheckStatus req) defManager
-     run $ modifyMVar_ deetsMVar $ const $ return v
-     case v of
-       Just _ -> assert False
-       _ -> return ()
+    v <- run $ finishPredicates preds (noCheckStatus req) manager
+    _ <- run $ tryPutMVar deetsMVar v
+    case v of
+      Just _ -> assert False
+      _ -> return ()
  case r of
    Success {} -> return ()
-    Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
-      "Failed:\n" ++ show x
+    Failure {..} -> do
+      mx <- tryReadMVar deetsMVar
+      case mx of
+        Just x ->
+          expectationFailure $ "Failed:\n" ++ show x
+        Nothing ->
+          expectationFailure $ "We failed to record a reason for failure: " <> show r
    GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
    NoExpectedFailure {} -> expectationFailure $ "No expected failure"
-    InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
-
+#if MIN_VERSION_QuickCheck(2,12,0)
+#else
+    InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
+#endif

 serverDoesntSatisfy :: (HasGenRequest a) =>
  Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
-serverDoesntSatisfy api burl args preds = do
-  let reqs = ($ burl) <$> genRequest api
+serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
+
+serverDoesntSatisfyMgr :: (HasGenRequest a) =>
+  Proxy a -> C.Manager -> BaseUrl -> Args -> Predicates -> Expectation
+serverDoesntSatisfyMgr api manager burl args preds = do
+  let reqs = ($ burl) <$> runGenRequest api
  r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
-     v <- run $ finishPredicates preds (noCheckStatus req) defManager
+     v <- run $ finishPredicates preds (noCheckStatus req) manager
     assert $ not $ null v
  case r of
    Success {} -> return ()
    GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
    Failure { output = m } -> expectationFailure $ "Failed:\n" ++ show m
    NoExpectedFailure {} -> expectationFailure $ "No expected failure"
-    InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
+#if MIN_VERSION_QuickCheck(2,12,0)
+#else
+    InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
+#endif

 noCheckStatus :: C.Request -> C.Request
+#if MIN_VERSION_http_client(0,5,0)
+noCheckStatus = id
+#else
 noCheckStatus r = r { C.checkStatus = \_ _ _ -> Nothing}
+#endif

 defManager :: C.Manager
 defManager = unsafePerformIO $ C.newManager C.defaultManagerSettings
--- a/stack-ghc-8.0.1.yaml
+++ b/stack-ghc-8.0.1.yaml
@ -1,10 +0,0 @@
-# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
-resolver: nightly-2016-09-07
-packages:
- '.'
-extra-deps:
- 'servant-0.8.1'
- 'servant-server-0.8.1'
- 'servant-client-0.8.1'
-flags: {}
-extra-package-dbs: []
--- a/stack.yaml
+++ b/stack.yaml
@ -1,7 +1,10 @@
-# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
-resolver: lts-6.17
+resolver: nightly-2018-09-03
 packages:
 - '.'
-extra-deps: []
+extra-deps:
+- hspec-discover-2.5.6
+- hspec-core-2.5.6
+- hspec-2.5.6
+- QuickCheck-2.12
 flags: {}
 extra-package-dbs: []
--- a/test/Doctest.hs
+++ b/test/Doctest.hs
@ -1,44 +0,0 @@
-module Main where
-
-import           Data.List            (isPrefixOf)
-import           System.Directory
-import           System.FilePath
-import           System.FilePath.Find
-import           Test.DocTest
-
-main :: IO ()
-main = do
-    files <- find always (extension ==? ".hs") "src"
-    mCabalMacrosFile <- getCabalMacrosFile
-    doctest $ "-isrc" : "-Iinclude" :
-              (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
-              "-XOverloadedStrings" :
-              "-XDeriveFunctor" :
-              "-XFlexibleInstances" :
-              "-XFlexibleContexts" :
-              "-XMultiParamTypeClasses" :
-              "-XDataKinds" :
-              "-XTypeOperators" :
-              "-XGADTs" :
-              files
-
-getCabalMacrosFile :: IO (Maybe FilePath)
-getCabalMacrosFile = do
-  exists <- doesDirectoryExist "dist"
-  if exists
-    then do
-      contents <- getDirectoryContents "dist"
-      let rest = "build" </> "autogen" </> "cabal_macros.h"
-      whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
-        [x] -> "dist" </> x </> rest
-        [] -> "dist" </> rest
-        xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
-                    ++ show xs ++ "\nTry cabal clean"
-    else return Nothing
- where
-  whenExists :: FilePath -> IO (Maybe FilePath)
-  whenExists file = do
-    exists <- doesFileExist file
-    return $ if exists
-      then Just file
-      else Nothing
--- a/test/Servant/QuickCheck/InternalSpec.hs
+++ b/test/Servant/QuickCheck/InternalSpec.hs
@ -1,19 +1,33 @@
 {-# LANGUAGE CPP #-}
 module Servant.QuickCheck.InternalSpec (spec) where

-import Control.Concurrent.MVar                    (newMVar, readMVar, swapMVar)
-import Control.Monad.IO.Class                     (liftIO)
-import Prelude.Compat
-import Servant
-import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
-import Test.Hspec                                 (Spec, context, describe, it,
-                                                   shouldBe, shouldContain)
-import Test.Hspec.Core.Spec                       (Arg, Example, Result (..),
-                                                   defaultParams,
-                                                   evaluateExample)
+
+import           Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
+import           Control.Exception       (SomeException)
+import           Control.Monad           (replicateM)
+import           Control.Monad.IO.Class  (liftIO)
+import qualified Data.ByteString         as BS
+import qualified Data.ByteString.Char8   as C
+import           Data.Maybe              (fromJust)
+import           Network.HTTP.Client     (path, queryString)
+import           Prelude.Compat
+import           Servant
+import           Servant.HTML.Blaze      (HTML)
+import qualified Text.Blaze.Html         as Blaze
+import qualified Text.Blaze.Html5        as Blaze5
+import           Test.Hspec              (Spec, context, describe, it, shouldBe,
+                                          shouldContain)
+import           Test.Hspec.Core.Spec    (Arg, Example, Result (..), ResultStatus (..),
+                                          defaultParams, safeEvaluateExample)
+import           Test.QuickCheck.Gen     (generate, unGen)
+import           Test.QuickCheck.Random  (mkQCGen)
+
+
+import Servant.Test.ComprehensiveAPI (comprehensiveAPIWithoutStreamingOrRaw)

 import Servant.QuickCheck
-import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
+import Servant.QuickCheck.Internal (genRequest, runGenRequest,
+                                    serverDoesntSatisfy)

 spec :: Spec
 spec = do
@ -21,6 +35,12 @@ spec = do
  serverSatisfiesSpec
  isComprehensiveSpec
  onlyJsonObjectSpec
+  notLongerThanSpec
+  queryParamsSpec
+  queryFlagsSpec
+  deepPathSpec
+  htmlDocTypesSpec
+  unbiasedGenerationSpec

 serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
@ -31,15 +51,42 @@ serversEqualSpec = describe "serversEqual" $ do
        serversEqual api burl1 burl2 args bodyEquality

  context "when servers are not equal" $ do
-
-
    it "provides the failing responses in the error message" $ do
-      Fail _ err <- withServantServer api2 server2 $ \burl1 ->
+      FailedWith err <- withServantServer api2 server2 $ \burl1 ->
        withServantServer api2 server3 $ \burl2 -> do
          evalExample $ serversEqual api2 burl1 burl2 args bodyEquality
+      show err `shouldContain` "Server equality failed"
      show err `shouldContain` "Body: 1"
      show err `shouldContain` "Body: 2"
-      show err `shouldContain` "Path: failplz/"
+      show err `shouldContain` "Path: /failplz"
+
+  context "when JSON is equal but looks a bit different as a ByteString" $ do
+
+    it "sanity check: different whitespace same JSON objects bodyEquality fails" $ do
+      FailedWith err <- withServantServer jsonApi jsonServer1 $ \burl1 ->
+        withServantServer jsonApi jsonServer2 $ \burl2 -> do
+          evalExample $ serversEqual jsonApi burl1 burl2 args bodyEquality
+      show err `shouldContain` "Server equality failed"
+
+    it "jsonEquality considers equal JSON apis equal regardless of key ordering or whitespace" $ do
+      withServantServerAndContext jsonApi ctx jsonServer1 $ \burl1 ->
+        withServantServerAndContext jsonApi ctx jsonServer2 $ \burl2 ->
+          serversEqual jsonApi burl1 burl2 args jsonEquality
+
+    it "sees when JSON apis are not equal because any value is different" $ do
+      FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
+        withServantServer jsonApi jsonServer3 $ \burl2 -> do
+          evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
+      show err `shouldContain` "Server equality failed"
+      show err `shouldContain` "Path: /jsonComparison"
+
+    it "sees when JSON apis are not equal due to different keys but same values" $ do
+      FailedWith err <- withServantServer jsonApi jsonServer2 $ \burl1 ->
+        withServantServer jsonApi jsonServer4 $ \burl2 -> do
+          evalExample $ serversEqual jsonApi burl1 burl2 args jsonEquality
+      show err `shouldContain` "Server equality failed"
+      show err `shouldContain` "Path: /jsonComparison"
+

 serverSatisfiesSpec :: Spec
 serverSatisfiesSpec = describe "serverSatisfies" $ do
@ -61,29 +108,123 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
  context "when predicates are false" $ do

    it "fails with informative error messages" $ do
-      Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
-        evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
-      err `shouldContain` "getsHaveCacheControlHeader"
-      err `shouldContain` "Headers"
-      err `shouldContain` "Body"
+      FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
+        evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
+      show err `shouldContain` "notAllowedContainsAllowHeader"
+      show err `shouldContain` "Headers"
+      show err `shouldContain` "Body"
+

 onlyJsonObjectSpec :: Spec
 onlyJsonObjectSpec = describe "onlyJsonObjects" $ do

  it "fails correctly" $ do
-    Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
+    FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
      evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
        (onlyJsonObjects <%> mempty)
-    err `shouldContain` "onlyJsonObjects"
+    show err `shouldContain` "onlyJsonObjects"

+  it "accepts non-JSON endpoints" $ do
+    withServantServerAndContext octetAPI ctx serverOctetAPI $ \burl ->
+      serverSatisfies octetAPI burl args (onlyJsonObjects <%> mempty)
+
+  it "does not fail when there is no content-type" $ do
+    withServantServerAndContext api2 ctx serverFailing $ \burl ->
+        serverSatisfies api2 burl args (onlyJsonObjects <%> mempty)
+
+notLongerThanSpec :: Spec
+notLongerThanSpec = describe "notLongerThan" $ do
+
+  it "fails correctly" $ do
+    FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
+      evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
+        (notLongerThan 1 <%> mempty)
+    show err `shouldContain` "notLongerThan"
+
+  it "succeeds correctly" $ do
+    withServantServerAndContext api ctx server $ \burl ->
+      serverSatisfies api burl args (notLongerThan 1000000000000 <%> mempty)

 isComprehensiveSpec :: Spec
 isComprehensiveSpec = describe "HasGenRequest" $ do

  it "has instances for all 'servant' combinators" $ do
-    let _g = genRequest comprehensiveAPIWithoutRaw
+    let _g = genRequest comprehensiveAPIWithoutStreamingOrRaw
    True `shouldBe` True -- This is a type-level check

+deepPathSpec :: Spec
+deepPathSpec = describe "Path components" $ do
+
+  it "are separated by slashes, without a trailing slash" $ do
+    let rng = mkQCGen 0
+        burl = BaseUrl Http "localhost" 80 ""
+        gen = runGenRequest deepAPI
+        req = (unGen gen rng 0) burl
+    path req `shouldBe` ("/one/two/three")
+
+
+queryParamsSpec :: Spec
+queryParamsSpec = describe "QueryParams" $ do
+
+  it "reduce to an HTTP query string correctly" $ do
+    let rng = mkQCGen 0
+        burl = BaseUrl Http "localhost" 80 ""
+        gen = runGenRequest paramsAPI
+        req = (unGen gen rng 0) burl
+        qs = C.unpack $ queryString req
+    qs `shouldBe` "one=_&two=_"
+
+queryFlagsSpec :: Spec
+queryFlagsSpec = describe "QueryFlags" $ do
+
+  it "reduce to an HTTP query string correctly" $ do
+    let rng = mkQCGen 0
+        burl = BaseUrl Http "localhost" 80 ""
+        gen = runGenRequest flagsAPI
+        req = (unGen gen rng 0) burl
+        qs = C.unpack $ queryString req
+    qs `shouldBe` "one&two"
+
+htmlDocTypesSpec :: Spec
+htmlDocTypesSpec = describe "HtmlDocTypes" $ do
+
+    it "fails HTML without doctype correctly" $ do
+      err <- withServantServerAndContext docTypeApi ctx noDocTypeServer $ \burl -> do
+        evalExample $ serverSatisfies docTypeApi burl args
+          (htmlIncludesDoctype <%> mempty)
+      show err `shouldContain` "htmlIncludesDoctype"
+
+    it "passes HTML with a doctype at start" $ do
+      withServantServerAndContext docTypeApi ctx docTypeServer $ \burl ->
+        serverSatisfies docTypeApi burl args (htmlIncludesDoctype <%> mempty)
+
+    it "accepts json endpoints and passes over them in silence" $ do
+      withServantServerAndContext api ctx server $ \burl -> do
+        serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
+          (htmlIncludesDoctype <%> mempty)
+
+
+makeRandomRequest :: Proxy LargeAPI -> BaseUrl -> IO Integer
+makeRandomRequest large burl = do
+  req <- generate $ runGenRequest large
+  pure $ fst . fromJust . C.readInteger . C.drop 1 . path $ req burl
+
+
+unbiasedGenerationSpec :: Spec
+unbiasedGenerationSpec = describe "Unbiased Generation of requests" $
+
+  it "frequency paired with generated endpoint should be more randomly distributed" $ do
+    let burl = BaseUrl Http "localhost" 80 ""
+    let runs = 10000 :: Double
+    someRequests <- replicateM 10000 (makeRandomRequest largeApi burl)
+    let mean = (sum $ map fromIntegral someRequests) / runs
+    let variancer x = let ix = fromIntegral x in (ix - mean) * (ix - mean)
+    let variance = (sum $ map variancer someRequests) / runs - 1
+    -- mean should be around 8.5. If this fails, we likely need more runs (or there's a bug!)
+    mean > 8 `shouldBe` True
+    mean < 9 `shouldBe` True
+    -- Std dev is likely around 4. Variance is probably greater than 20.
+    variance > 19.5 `shouldBe` True

 ------------------------------------------------------------------------------
 -- APIs
@ -96,6 +237,17 @@ type API = ReqBody '[JSON] String :> Post '[JSON] String
 api :: Proxy API
 api = Proxy

+type ParamsAPI = QueryParam "one" () :> QueryParam "two" () :> Get '[JSON] ()
+
+paramsAPI :: Proxy ParamsAPI
+paramsAPI = Proxy
+
+type FlagsAPI = QueryFlag "one" :> QueryFlag "two" :> Get '[JSON] ()
+
+flagsAPI :: Proxy FlagsAPI
+flagsAPI = Proxy
+
+
 server :: IO (Server API)
 server = do
    mvar <- newMVar ""
@ -109,23 +261,105 @@ type API2 = "failplz" :> Get '[JSON] Int
 api2 :: Proxy API2
 api2 = Proxy

+type DeepAPI = "one" :> "two" :> "three":> Get '[JSON] ()
+
+deepAPI :: Proxy DeepAPI
+deepAPI = Proxy
+
+
 server2 :: IO (Server API2)
 server2 = return $ return 1

 server3 :: IO (Server API2)
 server3 = return $ return 2

+serverFailing :: IO (Server API2)
+serverFailing = return . throwError $ err405
+
+-- With Doctypes
+type HtmlDoctype = Get '[HTML] Blaze.Html
+
+docTypeApi :: Proxy HtmlDoctype
+docTypeApi = Proxy
+
+docTypeServer :: IO (Server HtmlDoctype)
+docTypeServer = pure $ pure $ Blaze5.docTypeHtml $ Blaze5.span "Hello Test!"
+
+noDocTypeServer :: IO (Server HtmlDoctype)
+noDocTypeServer = pure $ pure $ Blaze.text "Hello Test!"
+
+
+-- Api for unbiased generation of requests tests
+largeApi :: Proxy LargeAPI
+largeApi = Proxy
+
+type LargeAPI
+  =    "1" :> Get '[JSON] Int
+  :<|> "2" :> Get '[JSON] Int
+  :<|> "3" :> Get '[JSON] Int
+  :<|> "4" :> Get '[JSON] Int
+  :<|> "5" :> Get '[JSON] Int
+  :<|> "6" :> Get '[JSON] Int
+  :<|> "7" :> Get '[JSON] Int
+  :<|> "8" :> Get '[JSON] Int
+  :<|> "9" :> Get '[JSON] Int
+  :<|> "10" :> Get '[JSON] Int
+  :<|> "11" :> Get '[JSON] Int
+  :<|> "12" :> Get '[JSON] Int
+  :<|> "13" :> Get '[JSON] Int
+  :<|> "14" :> Get '[JSON] Int
+  :<|> "15" :> Get '[JSON] Int
+  :<|> "16" :> Get '[JSON] Int
+
+
+type OctetAPI = Get '[OctetStream] BS.ByteString
+
+octetAPI :: Proxy OctetAPI
+octetAPI = Proxy
+
+serverOctetAPI :: IO (Server OctetAPI)
+serverOctetAPI = return $ return "blah"
+
+type JsonApi = "jsonComparison" :> Get '[OctetStream] BS.ByteString
+
+jsonApi :: Proxy JsonApi
+jsonApi = Proxy
+
+jsonServer1 :: IO (Server JsonApi)
+jsonServer1 = return $ return "{ \"b\": [\"b\"], \"a\": 1 }"  -- whitespace, ordering different
+
+jsonServer2 :: IO (Server JsonApi)
+jsonServer2 = return $ return "{\"a\": 1,\"b\":[\"b\"]}"
+
+jsonServer3 :: IO (Server JsonApi)
+jsonServer3 = return $ return "{\"a\": 2, \"b\": [\"b\"]}"
+
+jsonServer4 :: IO (Server JsonApi)
+jsonServer4 = return $ return "{\"c\": 1, \"d\": [\"b\"]}"
+
+
 ctx :: Context '[BasicAuthCheck ()]
 ctx = BasicAuthCheck (const . return $ NoSuchUser) :. EmptyContext
 ------------------------------------------------------------------------------
 -- Utils
 ------------------------------------------------------------------------------
-
-evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
-evalExample e = evaluateExample e defaultParams ($ ()) progCallback
+evalExample :: (Example e, Arg e ~ ()) => e -> IO EvalResult
+evalExample e = do
+  r <- safeEvaluateExample e defaultParams ($ ()) progCallback
+  case resultStatus r of
+    Success          -> return $ AllGood
+    Failure _ reason -> return $ FailedWith $ show reason
+    Pending {}       -> error "should not happen"
  where
    progCallback _ = return ()

+data EvalResult
+  = AnException SomeException
+  | AllGood
+  | FailedWith String
+  deriving (Show)
+
+
 args :: Args
 args = defaultArgs { maxSuccess = noOfTestCases }
Author	SHA1	Message	Date
fisx	0535413b1a	Merge pull request #72 from maksbotan/maksbotan/support-servant-0.18 Support servant-server-0.18	2020-07-31 09:54:59 +02:00
Maxim Koltsov	7cc95a8120	Update src/Servant/QuickCheck/Internal/QuickCheck.hs Co-authored-by: fisx <mf@zerobuzz.net>	2020-07-31 10:43:19 +03:00
Maxim Koltsov	e1a919127a	haskell-ci regenerate	2020-07-30 19:32:29 +03:00
Maxim Koltsov	e6daf03c16	Support servant-server-0.18	2020-07-30 19:22:14 +03:00
Matthias Fischmann	7926ad6bdb	Fix lower version bounds for servant packages.	2020-07-10 13:54:21 +02:00
Matthias Fischmann	fa9cc11095	Bump version; add changelog entry.	2020-07-02 22:40:04 +02:00
Julian Arni	dfec2529ac	Merge pull request #65 from fizruk/support-servant-0.15 Support servant-0.15	2020-06-25 12:10:58 +02:00
Julian Arni	eb3cdbcd3a	Merge branch 'master' into support-servant-0.15	2020-06-25 11:02:24 +02:00
Julian Arni	f48088b7d2	Merge pull request #70 from felixmulder/relax-constraints-for-GHC-8.10 Relax constraints for GHC 8.10	2020-06-25 11:00:59 +02:00
Felix Mulder	2bf03e822a	Relax constraints for GHC 8.10	2020-06-07 09:58:56 +02:00
Oleg Grenrus	092ebe5423	Merge pull request #68 from haskell-servant/servant-0.17 Support servant-0.17	2020-01-24 10:45:48 +02:00
Oleg Grenrus	13d32d6768	Support servant-0.17	2020-01-23 23:38:03 +02:00
Oleg Grenrus	8e8e9b501b	Change version back to 0.0.7.4 There are no changes since the tag in the src/	2019-09-16 02:11:42 +03:00
Oleg Grenrus	c93bd5a832	Merge pull request #66 from haskell-servant/updates Updates: 2019-09	2019-09-16 02:09:26 +03:00
Oleg Grenrus	f9989bbf79	Updates: 2019-09	2019-09-15 18:22:05 +03:00
Nickolay Kudasov	bb8177928e	Support servant-0.15	2019-07-04 11:52:51 +03:00
Oleg Grenrus	f6fb9033e9	Merge pull request #63 from haskell-servant/updates Support servant-0.16 and http-media-0.8	2019-04-17 12:28:42 +03:00
Oleg Grenrus	804b06283d	Update .travis.yml	2019-04-17 11:36:31 +03:00
Oleg Grenrus	a5cdf78d82	Support servant-0.16 and http-media-0.8	2019-04-16 22:19:54 +03:00
Oleg Grenrus	638580ba49	Merge pull request #62 from haskell-servant/servant-0.16 Allow servant-0.16	2019-02-28 00:05:15 +02:00
Oleg Grenrus	8803b1c09e	Allow servant-0.16	2019-02-27 20:42:16 +02:00
parsonsmatt	e69d4026af	v0.0.7.3	2018-10-24 07:48:05 -06:00
Oleg Grenrus	98fd048bdc	Merge pull request #59 from haskell-servant/ghc-8.6 Support GHC-8.6	2018-10-15 21:13:54 +03:00
Oleg Grenrus	902d7a7583	Support GHC-8.6	2018-10-15 17:51:44 +03:00
parsonsmatt	bc36737c45	Clean up stack.yaml and dependencies	2018-10-12 13:34:13 -06:00
parsonsmatt	0190e5e737	QuickCheck 2.12 Compatibility This commit relaxes the bounds on QuickCheck, allowing it to be compatible with 2.12. In order to be compatible with 2.12, we had to CPP some definitions that referenced code that was deleted.	2018-10-12 13:34:13 -06:00
Alp Mestanogullari	7d6a97af5a	Merge pull request #57 from Phenitei/notAllowedBug Fix #56: a notAllowedContainsAllowHeader bug	2018-08-29 12:01:14 +02:00
Joachim Desroches	9743ac5ec4	Fix a bug in onlyJsonObjects that made it fail if there was no content-type.	2018-08-27 22:31:18 -06:00
Joachim Desroches	e3bf044741	Add test for onlyJsonObjects when no content-type header is present.	2018-08-27 22:31:18 -06:00
Joachim Desroches	89c9170bdf	Fix #56 A bug where the request printed alongside a failure in notAllowedContainsAllowHeader was not the request causing the failure.	2018-08-27 18:12:22 +02:00
Oleg Grenrus	35c98622fc	Merge pull request #53 from haskell-servant/servant-0.14 Support servant-0.14	2018-06-19 14:51:14 +03:00
Oleg Grenrus	cb06284c75	Support servant-0.14	2018-06-19 13:05:16 +03:00
Matt Parsons	4dfcc862e7	v0.0.7.2 (#51 ) * Prepare for 0.0.7.2 release	2018-05-10 11:32:50 -06:00
Matt Parsons	ae40f3d9f7	Fix stack.yaml file (#46 ) * Fix stack.yaml file * Remove unfixable stack files	2018-05-10 10:09:12 -06:00
Matt Parsons	d66c2d278a	Safer MVar usage (#49 ) * Fix stack.yaml file * Remove unfixable stack files * Resolve ambiguous import in GHCi * handle MVars without error * Consistent messaging * Add comment	2018-05-10 10:08:06 -06:00
Julian Arni	78f30bc997	Merge pull request #50 from parsonsmatt/matt/configurable-manager Allow clients to pass a manager in	2018-05-10 14:37:18 +02:00
parsonsmatt	b4a69516d2	Allow clients to pass a manager in	2018-05-09 14:30:38 -06:00
Oleg Grenrus	226c7647e1	Merge pull request #44 from haskell-servant/base-compat-0.10 Allow base-compat-0.10	2018-04-13 18:29:29 +03:00
Oleg Grenrus	26523832f8	Allow base-compat-0.10 and temporary-1.3 Use base-compat-batteries	2018-04-12 09:29:23 +03:00
Oleg Grenrus	d262cead57	Merge pull request #43 from haskell-servant/ghc-8.4.1 Support GHC-8.4.1	2018-03-23 08:21:16 +02:00
Oleg Grenrus	4757df4195	Support GHC-8.4.1	2018-03-23 08:13:36 +02:00
Oleg Grenrus	76a0394cea	Merge pull request #42 from haskell-servant/servant-0.13 Support for servant-0.13	2018-02-09 21:43:51 +02:00
Oleg Grenrus	d46b7183ad	Support for servant-0.13	2018-02-09 20:26:02 +02:00
Julian K. Arni	35bd148037	Changelog and bump version	2017-12-14 21:37:18 -08:00
Julian K. Arni	bc301ad7c1	Bump to 0.0.4.0	2017-12-14 21:35:11 -08:00
Julian Arni	0f334449cb	Merge pull request #40 from Phenitei/expose-missing-predicates Add forgotten predicates to export list.	2017-12-14 21:33:22 -08:00
Joachim Desroches	4f24452d03	Add forgotten predicates to export list. The honoursAcceptHeader and getsHaveLastModifiedHeader predicates had been omitted when writing the export list, making it necessary to import Servant.QuickCheck.Internal.Predicates to have access to them.	2017-12-15 00:22:57 +01:00
Oleg Grenrus	6e6595f68c	Merge pull request #37 from phadej/servant-0.12 Support for servant-0.12	2017-11-08 13:27:13 +02:00
Oleg Grenrus	53785354d3	Add build-tool-depends	2017-11-08 13:02:46 +02:00
Oleg Grenrus	026d4b8bb4	Use new-build based .travis.yml	2017-11-08 11:39:45 +02:00
Oleg Grenrus	3571f543fd	Support for servant-0.12	2017-11-08 10:49:31 +02:00
Erik	d65abc856f	[READY] Fixes #7 : Add HTML missing Doctype predicate with tests (#33 ) * Add HTML missing Doctype predicate with tests * Don't use 'fail' in predicates * Add RFC reference and description for HTML doctype * Only take enough of respBody to compare to doctype string	2017-10-21 15:20:56 -07:00
Julian K. Arni	54a05a53a9	Bump version	2017-10-19 10:12:36 -07:00
Julian Arni	4765664a3e	Merge pull request #32 from adinapoli-iohk/support-servant-0.11 Tentatively support Servant 0.11	2017-10-19 10:11:40 -07:00
Alfredo Di Napoli	199f6cc51e	Code review changes	2017-10-19 09:20:49 +02:00
Julian Arni	fb14b3c7ea	Merge pull request #35 from haskell-servant/issue-34/coverage Add coverage reports	2017-10-18 11:49:19 -07:00
Julian K. Arni	cb4555d6ba	Add coverage reports	2017-10-18 11:30:13 -07:00
Alfredo Di Napoli	b0febe7c58	Tentatively support Servant 0.11	2017-10-18 14:36:45 +02:00
Julian K. Arni	9ebfe9d630	Bump version	2017-10-16 09:13:22 -07:00
Julian K. Arni	fa1a03257e	Documenation for jsonEquality	2017-10-16 09:11:43 -07:00
Julian K. Arni	cce3bef538	Update changelog	2017-10-16 09:04:45 -07:00
Julian Arni	40c576cf15	Merge pull request #30 from haskell-servant/jsonEquality Add jsonEquality to compare JSON APIs	2017-10-16 08:58:53 -07:00
Erik Aker	6c163dc981	Utilize new FailedWith constructor to fix json equality tests	2017-10-15 20:31:52 -07:00
Erik Aker	3f6856103a	Add sanity check test in there to prove jsonEquality really is doing something different	2017-10-15 20:24:21 -07:00
Erik Aker	482656b35e	Create jsonEqaulity function and add some tests for similar JSON values but slightly different whitespace, ordering	2017-10-15 20:24:21 -07:00
Julian Arni	e7206ec875	Merge pull request #29 from haskell-servant/issue-27/supportHspec2.4 Upgrade hspec to 2.4.4 and use safeEvaluateExample for tests	2017-10-15 18:45:03 -07:00
Julian K. Arni	a0ec1777a7	Compatibility with earlier versions of hspec. Adds CPP to the tests to allow for upstream changes to the 'Result' type.	2017-10-15 17:49:47 -07:00
Erik Aker	f3b4fcf7a9	Resolve merge conflicts with unbiasedGeneration merge	2017-10-14 08:16:30 -07:00
Julian Arni	66ce50993f	Unbias generation of requests. (#19 ) * Unbias generation of requests: ...so that each endpoint is picked with the same frequency. Also, include a test for unbiased generation that measures mean and variance of results.	2017-10-14 07:53:04 -07:00
Erik Aker	0e23a2eba7	Code cleanup: remove unused imports and code	2017-07-15 15:11:18 -07:00
Erik Aker	f052dc149b	Bump HSpec to 2.4.4 and make tests use safeEvaluateExample to capture failure msg	2017-07-15 15:03:06 -07:00
Julian K. Arni	e1a9db4924	Bump version	2017-03-11 09:36:16 -06:00
Julian Arni	f12034ccb6	Merge pull request #28 from declension/22-fix-path-delimiting Fix path delimiting (#22)	2017-03-11 09:34:28 -06:00
Nick B	d33214d376	Fix Path delimiting: * Add test API with multiple Path elements * Add basic test using this API, generating an endpoint to validate that query path delimiting is happening correctly (that fails on `master`) * Fix (re)creation of path to prepend `/` to each new path section, but only if it's non-empty (this fixes the trailing slashes, but still allows users to use a `:> "foo/" :>...` if their API demands trailing slashes) * Update / fix the existing test that now fails slightly differently (i.e. the trailing slash in `failplz/` is gone) Fixes #22.	2017-03-11 11:19:57 +00:00
Julian K. Arni	41b2faad45	Bump version.	2017-03-10 21:50:50 -06:00
Julian Arni	78e0b32019	Merge pull request #26 from haskell-servant/fix-ci Fix ci	2017-03-10 21:48:14 -06:00
Julian K. Arni	b7cf4e6f80	upper bound for hspec	2017-03-10 17:29:08 -06:00
Julian K. Arni	a8dd02516f	Switch CI to stack	2017-03-10 15:53:26 -06:00
Julian Arni	be5909d30f	Merge pull request #24 from declension/23-fix-queryparams Fix multiple QueryParams / QueryFlags	2017-03-10 15:31:39 -06:00
Nick B	2109326ad7	QueryFlags don't use = * Also, fix import for old `Servant` versions - _every_ version now needs `Data.Bytestring` (i.e. Servant version < 0.8, as per old lts in `stack.yaml`)	2017-03-10 08:31:56 +00:00
Nick B	77fa490b93	Fix QueryFlags too (#23 ) * Same logic / testing as for `QueryParam` * There's probably some de-duplication that could be done here one day...	2017-03-07 22:52:38 +00:00
Nick B	a8459223ed	Use () for test QueryParam type too ...as suggested (thanks @jkarni)	2017-03-07 22:48:45 +00:00
Nick B	6be6697165	QueryParams: fix ampersand, improve test * Simplify test API to use `()` - no awkward values at all. * The test asserts on _entire_ of resulting path now... * ...and fix the ampersand placement, but preserving the order of params left to right. The code also reads a bit better this way...	2017-03-07 21:25:11 +00:00
Nick B	a5224276d5	Fix multiple QueryParams * Add test API taking multiple `QueryParam`s * Add basic test using this API, generating an endpoint to ensure correct HTTP `one=foo&two=bar` query string generation is happening (that fails on `master`) * Fix (re)creation of query string to append `&` before the new parameter if there is already a built query string. Fixes #23.	2017-03-06 13:32:55 +00:00
Julian K. Arni	47391784ce	Bump version	2016-10-18 14:40:40 +02:00
Julian K. Arni	b1227d3864	Make onlyJsonObjects succeed in non-JSON endpoints.	2016-10-18 14:38:44 +02:00
Julian K. Arni	4f5e6ba25a	Mention that servant servers don't comply with allow header setting	2016-10-18 13:55:28 +02:00
Julian K. Arni	ae07497397	Bump version to 0.2.0.1	2016-10-05 15:36:38 +01:00
Julian Arni	49cfb78f1d	Merge pull request #17 from haskell-servant/notLongerThan Add notLongerThan predicate.	2016-10-05 16:33:01 +02:00
Julian K. Arni	2219d2ef7e	Changelog for notLongerThan.	2016-10-05 15:32:37 +01:00
Julian K. Arni	feff40b2e4	Add notLongerThan predicate.	2016-10-05 15:29:39 +01:00
Julian K. Arni	b4876468e6	Changelog	2016-10-03 16:39:36 +02:00
Julian K. Arni	0563caafae	Newtype rather than data for predicates	2016-10-03 16:32:27 +02:00
Julian K. Arni	8eb5c334c1	Looser bounds. Support recent versions of QuickCheck, aeson, http-client, servant, servant-client, and servant-server.	2016-10-03 16:30:46 +02:00
Julian K. Arni	f36f544ee6	Add predicate getsHaveLastModifiedHeader.	2016-10-03 15:39:46 +02:00