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

Support servant-server-0.18

.gitignore

@@ -3,3 +3,4 @@ scripts/
 samples/
 test-servers/
 /doc/
+.stack-work/

.travis.yml

@@ -1,34 +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
-
+os: linux
-env:
+dist: xenial
-  - GHCVER=7.8.4
+git:
-  - GHCVER=7.10.2
+  # whether to recursively clone submodules
-
+  submodules: false
-addons:
+branches:
-  apt:
+  only:
-    sources:
+    - master
-      - hvr-ghc
-    packages:
-      - ghc-7.8.4
-      - ghc-7.10.2
-      - cabal-install-1.22
-      - libgmp-dev
-      - wrk
-
-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/1.22/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
-  #- (cd doc && tinc cabal configure --enable-tests && cabal build && cabal test)
-
 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

CHANGELOG.yaml

@@ -0,0 +1,214 @@
+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:
+
+      - description: Update CHANGELOG to YAML syntax.
+        pr: 16
+        authors: jkarni
+        date: 2016-09-14
+
+      - description: Support new CaptureAll combinator
+        pr: 16
+        authors: jkarni
+        date: 2016-09-14
+
+      - description: Support GHC 8
+        pr: 16
+        authors: jkarni
+        date: 2016-09-14
+
+  - version: "0.0.1.1"
+    changes:
+
+      - description: Exclude GHC 7.8 (by bumping base lower bound to 4.8)
+        pr: none
+        authors: jkarni
+
+      - description: More generous bounds for other packages.
+        pr: none
+        authors: jkarni
+
+  - version: "0.0.1.0"
+    changes:
+
+      - description: Better error messages.
+        notes: >
+          Error messages now contain failing predicate, failing response and
+          (except for response predicates), failing requests.
+        pr: none
+        authors: jkarni
+
+      - description: Signicant changes to RequestPredicate and ResponsePredicate types.
+        pr: none
+        authors: jkarni

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

cabal.project

@@ -0,0 +1,4 @@
+packages: .
+tests: true
+
+allow-newer: servant-blaze:servant

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)

servant-quickcheck.cabal

@@ -1,100 +1,138 @@
-name:                servant-quickcheck
+name:               servant-quickcheck
-version:             0.0.0.0
+version:            0.0.9.1
-synopsis:            QuickCheck entire APIs
+synopsis:           QuickCheck entire APIs
 description:
- This packages provides QuickCheck properties that are tested across an entire
+  This packages provides QuickCheck properties that are tested across an entire
- API.
+  API.
 
-license:             BSD3
+license:            BSD3
-license-file:        LICENSE
+license-file:       LICENSE
-author:              Julian K. Arni
+author:             Julian K. Arni
-maintainer:          jkarni@gmail.com
+maintainer:         jkarni@gmail.com
-category:            Web
+category:           Web
-build-type:          Simple
+build-type:         Simple
-cabal-version:       >=1.10
+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
+  location: https://github.com/haskell-servant/servant-quickcheck
 
 flag long-tests
   description: Run more QuickCheck tests
   default:     False
 
 library
-  exposed-modules:     Servant.QuickCheck
+  exposed-modules:
-                     , Servant.QuickCheck.Internal
+    Servant.QuickCheck
-                     , Servant.QuickCheck.Internal.Predicates
+    Servant.QuickCheck.Internal
-                     , Servant.QuickCheck.Internal.HasGenRequest
+    Servant.QuickCheck.Internal.Equality
-                     , Servant.QuickCheck.Internal.QuickCheck
+    Servant.QuickCheck.Internal.ErrorTypes
-                     , Servant.QuickCheck.Internal.Equality
+    Servant.QuickCheck.Internal.HasGenRequest
-                     , Servant.QuickCheck.Internal.ErrorTypes
+    Servant.QuickCheck.Internal.Predicates
-  build-depends:       base >=4.7 && <4.9
+    Servant.QuickCheck.Internal.QuickCheck
-                     , base-compat == 0.9.*
-                     , QuickCheck == 2.8.*
-                     , bytestring == 0.10.*
-                     , aeson > 0.10 && < 0.12
-                     , mtl == 2.2.*
-                     , http-client == 0.4.*
-                     , http-types == 0.9.*
-                     , http-media == 0.6.*
-                     , servant-client == 0.7.*
-                     , servant-server == 0.7.*
-                     , string-conversions == 0.4.*
-                     , data-default-class == 0.0.*
-                     , servant == 0.7.*
-                     , warp >= 3.2.4 && < 3.3
-                     , process == 1.2.*
-                     , temporary == 1.2.*
-                     , split == 0.2.*
-                     , case-insensitive == 1.2.*
-                     , hspec == 2.2.*
-                     , text == 1.*
-                     , pretty == 1.1.*
-  if impl(ghc < 7.10)
-    build-depends:     bifunctors == 5.*
 
-  hs-source-dirs:      src
+  build-depends:
-  default-extensions:  TypeOperators
+      aeson                  >=0.8    && <2
-                     , FlexibleInstances
+    , base                   >=4.9    && <4.15
-                     , FlexibleContexts
+    , base-compat-batteries  >=0.10.1 && <0.12
-                     , DataKinds
+    , bytestring             >=0.10   && <0.11
-                     , GADTs
+    , case-insensitive       >=1.2    && <1.3
-                     , MultiParamTypeClasses
+    , clock                  >=0.7    && <0.9
-                     , DeriveFunctor
+    , data-default-class     >=0.0    && <0.2
-                     , KindSignatures
+    , hspec                  >=2.5.6  && <2.8
-                     , RankNTypes
+    , http-client            >=0.4.30 && <0.8
-                     , ConstraintKinds
+    , http-media             >=0.6    && <0.9
-                     , DeriveGeneric
+    , http-types             >=0.8    && <0.13
-                     , ScopedTypeVariables
+    , mtl                    >=2.1    && <2.3
-                     , OverloadedStrings
+    , pretty                 >=1.1    && <1.2
-                     , FunctionalDependencies
+    , process                >=1.2    && <1.7
-                     , NoImplicitPrelude
+    , QuickCheck             >=2.7    && <2.15
-  default-language:    Haskell2010
+    , 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
+  type:               exitcode-stdio-1.0
-  ghc-options:         -Wall -threaded
+  ghc-options:        -Wall -threaded
-  default-language:    Haskell2010
+  default-language:   Haskell2010
-  hs-source-dirs:      test
+  hs-source-dirs:     test
-  main-is:             Spec.hs
+  main-is:            Spec.hs
-  other-modules:       Servant.QuickCheck.InternalSpec
+  other-modules:      Servant.QuickCheck.InternalSpec
-  build-depends:       base == 4.*
+  build-tool-depends: hspec-discover:hspec-discover -any
-                     , base-compat
+  build-depends:
-                     , servant-quickcheck
+      aeson
-                     , hspec
+    , base
-                     , hspec-core
+    , base-compat-batteries
-                     , http-client
+    , blaze-html
-                     , warp
+    , bytestring
-                     , servant-server
+    , hspec
-                     , servant-client
+    , hspec-core             >=2.5.5 && <2.8
-                     , servant
+    , http-client
-                     , transformers
+    , QuickCheck
-                     , QuickCheck
+    , quickcheck-io
-                     , quickcheck-io
+    , servant
-  default-extensions:  TypeOperators
+    , servant-blaze
-                     , FlexibleInstances
+    , servant-client
-                     , FlexibleContexts
+    , servant-quickcheck
-                     , GADTs
+    , servant-server
-                     , DataKinds
+    , transformers
-                     , NoImplicitPrelude
+    , warp
-                     , OverloadedStrings
+
-                     , ScopedTypeVariables
+  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

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(..)
@@ -69,10 +76,10 @@ module Servant.QuickCheck
 
   ) where
 
+import Data.Proxy                  (Proxy (..))
+import Servant.Client              (BaseUrl (..), Scheme (..))
 import Servant.QuickCheck.Internal
-import Servant.Client (BaseUrl(..), Scheme(..))
+import Test.QuickCheck             (Args (..), stdArgs)
-import Test.QuickCheck (Args(..), stdArgs)
-import Data.Proxy (Proxy(..))
 
 -- | QuickCheck @Args@ with 1000 rather than 100 test cases.
 --

src/Servant/QuickCheck/Internal.hs

@@ -1,7 +1,7 @@
 module Servant.QuickCheck.Internal (module X) where
 
+import Servant.QuickCheck.Internal.Equality      as X
+import Servant.QuickCheck.Internal.ErrorTypes    as X
 import Servant.QuickCheck.Internal.HasGenRequest as X
-import Servant.QuickCheck.Internal.Predicates as X
+import Servant.QuickCheck.Internal.Predicates    as X
-import Servant.QuickCheck.Internal.QuickCheck as X
+import Servant.QuickCheck.Internal.QuickCheck    as X
-import Servant.QuickCheck.Internal.Equality as X
-import Servant.QuickCheck.Internal.ErrorTypes as X

src/Servant/QuickCheck/Internal/Equality.hs

@@ -1,16 +1,23 @@
 module Servant.QuickCheck.Internal.Equality where
 
-import           Data.Function       (on)
+import Data.Aeson          (Value, decode, decodeStrict)
-import           Network.HTTP.Client (Response, responseBody)
+import Data.ByteString     (ByteString)
-import           Prelude.Compat
+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 ->
+  mappend = (<>)
-    a x y && b x y
 
 -- | 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

src/Servant/QuickCheck/Internal/ErrorTypes.hs

@@ -1,15 +1,40 @@
+{-# LANGUAGE CPP #-}
 module Servant.QuickCheck.Internal.ErrorTypes where
 
 import           Control.Exception       (Exception (..))
 import qualified Data.ByteString.Lazy    as LBS
 import           Data.String.Conversions (cs)
 import qualified Data.Text               as T
+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)
+
+instance Exception ServerEqualityFailure where
+
+instance Show PredicateFailure where
+  show = render . prettyPredicateFailure
+
+
+data ServerEqualityFailure
+  = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)
+  deriving (Typeable, Generic)
+
+instance Show ServerEqualityFailure where
+  show = render . prettyServerEqualityFailure
+
+
+instance Exception PredicateFailure where
+
+-- * Pretty printing
+
 prettyHeaders :: [Header] -> Doc
 prettyHeaders hdrs = vcat $ prettyHdr <$> hdrs
   where
@@ -35,12 +60,6 @@ prettyResp r =
   $$ text "Body:"     <+> (nest 5 $ text . cs $ C.responseBody r))
 
 
--- The error that occurred.
-data PredicateFailure = PredicateFailure T.Text (Maybe C.Request) (C.Response LBS.ByteString)
-  deriving (Generic)
-
-data ServerEqualityFailure = ServerEqualityFailure C.Request (C.Response LBS.ByteString) (C.Response LBS.ByteString)
-  deriving (Generic)
 
 prettyServerEqualityFailure :: ServerEqualityFailure -> Doc
 prettyServerEqualityFailure (ServerEqualityFailure req resp1 resp2) =
@@ -61,12 +80,3 @@ prettyPredicateFailure (PredicateFailure predicate req resp) =
       Nothing -> text ""
       Just v  -> prettyReq v
 
-instance Show ServerEqualityFailure where
-  show = render . prettyServerEqualityFailure
-
-instance Exception ServerEqualityFailure where
-
-instance Show PredicateFailure where
-  show = render . prettyPredicateFailure
-
-instance Exception PredicateFailure where

src/Servant/QuickCheck/Internal/HasGenRequest.hs

@@ -1,98 +1,148 @@
+{-# LANGUAGE CPP       #-}
 {-# LANGUAGE PolyKinds #-}
 module Servant.QuickCheck.Internal.HasGenRequest where
 
-import           Data.Default.Class       (def)
+import Data.String              (fromString)
-import           Data.Monoid              ((<>))
+import Data.String.Conversions  (cs)
-import           Data.String              (fromString)
+import GHC.TypeLits             (KnownSymbol, Nat, symbolVal)
-import           Data.String.Conversions  (cs)
+import Network.HTTP.Client      (Request, RequestBody (..), host, method, path,
-import           GHC.TypeLits             (KnownSymbol, Nat, symbolVal)
+                                 port, queryString, requestBody, requestHeaders,
-import           Network.HTTP.Client      (Request, RequestBody (..), host,
+                                 secure, defaultRequest)
-                                           method, path, port, queryString,
+import Network.HTTP.Media       (renderHeader)
-                                           requestBody, requestHeaders, secure)
+import Prelude.Compat
-import           Network.HTTP.Media       (renderHeader)
+import Servant
-import           Prelude.Compat
+import Servant.API.ContentTypes (AllMimeRender (..))
-import           Servant
+import Servant.Client           (BaseUrl (..), Scheme (..))
-import           Servant.API.ContentTypes (AllMimeRender (..))
+import Test.QuickCheck          (Arbitrary (..), Gen, elements, frequency)
-import           Servant.Client           (BaseUrl (..), Scheme (..))
+
-import           Test.QuickCheck          (Arbitrary (..), Gen, elements, oneof)
+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)
+      = (lf + rf, frequency [l, r])
-              , genRequest (Proxy :: Proxy b)
+      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
+    => HasGenRequest (Capture' mods x c :> b) where
-    genRequest _ = do
+    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
 
-instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
+instance (Arbitrary c, HasGenRequest b, ToHttpApiData c )
-    => HasGenRequest (Header h c :> b) where
+    => HasGenRequest (CaptureAll x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
       old' <- old
-      new' <- toUrlPiece <$> new
+      new' <- fmap (cs . toUrlPiece) <$> new
-      return $ \burl -> let r = old' burl in r {
+      let new'' = BS.intercalate "/" new'
-          requestHeaders = (hdr, cs new') : requestHeaders 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]
+
+instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
+    => HasGenRequest (Header' mods h c :> b) where
+    genRequest _ = (oldf, do
+      old' <- old
+      new' <- toUrlPiece <$> new  -- TODO: generate lenient or/and optional
+      return $ \burl -> let r = old' burl in r {
+          requestHeaders = (hdr, cs new') : requestHeaders r })
+      where
+        (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
+    => HasGenRequest (ReqBody' mods x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
-      old' <- old
+      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
+    => HasGenRequest (QueryParam' mods x c :> b) where
-    genRequest _ = do
+    genRequest _ = (oldf, do
-      new' <- new
+      new' <- new  -- TODO: generate lenient or/and optional
       old' <- old
-      return $ \burl -> let r = old' burl in r {
+      return $ \burl -> let r = old' burl
-          queryString = queryString r
+                            newExpr = param <> "=" <> cs (toQueryParam new')
-                     <> 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)
@@ -100,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 {
+      return $ \burl -> let r = old' burl
-          queryString = queryString r <> param <> "=" }
+                            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)

src/Servant/QuickCheck/Internal/Predicates.hs

@@ -1,30 +1,33 @@
 module Servant.QuickCheck.Internal.Predicates where
 
-import Control.Exception (catch, SomeException, throw)
+import           Control.Exception     (catch, throw)
-import           Control.Monad         (liftM2, guard, ap)
+import           Control.Monad         (liftM2, unless, when)
-import           Control.Monad.Reader
 import           Data.Aeson            (Object, decode)
-import           Data.Bifunctor        (Bifunctor (..))
+import           Data.Bifunctor        (first)
-import           Prelude.Compat
 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           Data.Text             (Text)
+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, parseUrl, requestHeaders,
+                                        method, parseRequest, requestHeaders,
                                         responseBody, responseHeaders,
                                         responseStatus)
 import           Network.HTTP.Media    (matchAccept)
 import           Network.HTTP.Types    (methodGet, methodHead, parseMethod,
-                                        renderStdMethod, status200, status201,
+                                        renderStdMethod, status100, status200,
-                                        status300, status401, status405,
+                                        status201, status300, status401,
-                                        status500, status100)
+                                        status405, status500)
+import           Prelude.Compat
+import           System.Clock          (Clock (Monotonic), diffTimeSpec,
+                                        getTime, toNanoSecs)
 
 import Servant.QuickCheck.Internal.ErrorTypes
 
@@ -40,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__]
 --
@@ -65,9 +84,13 @@ not500 = ResponsePredicate $ \resp ->
 -- /Since 0.0.0.0/
 onlyJsonObjects :: ResponsePredicate
 onlyJsonObjects
-  = ResponsePredicate (\resp -> case decode (responseBody resp) of
+  = ResponsePredicate (\resp -> do
-      Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
+    case lookup "content-type" (first foldedCase <$> responseHeaders resp) of
-      Just (_ :: Object) -> return ())
+      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__
 --
@@ -95,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 parseUrl $ SBSC.unpack l of
+             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]
 
-{-
+-- | [__Optional__]
-getsHaveLastModifiedHeader :: ResponsePredicate
+--
+-- 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__]
 --
@@ -121,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 }
+      let reqs = [ req { method = renderStdMethod m } | m <- [minBound .. maxBound]
-                                        | m <- [minBound .. maxBound ]
+                                                      , renderStdMethod m /= method req ]
-                                        , renderStdMethod m /= method req ]
+      resp <- mapM (flip httpLbs mgr) reqs
-      case filter pred' resp of
+
-        (x:xs) -> throw $ PredicateFailure "notAllowedContainsAllowHeader" (Just req) x
+      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)
@@ -167,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]
 
@@ -278,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
@@ -292,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
+newtype RequestPredicate = RequestPredicate
-  { getRequestPredicate    :: Request -> Manager -> IO [Response LBS.ByteString]
+  { 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)
+  mappend = (<>)
-                             (responsePredicates a <> responsePredicates b)
 
 class JoinPreds a where
   joinPreds :: a -> Predicates -> Predicates
@@ -358,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 ()
+isRFC822Date :: SBS.ByteString -> Bool
-status2XX r t
+isRFC822Date s
-  | status200 <= responseStatus r && responseStatus r < status300
+  = 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

src/Servant/QuickCheck/Internal/QuickCheck.hs

@@ -1,30 +1,31 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE CPP #-}
 module Servant.QuickCheck.Internal.QuickCheck where
 
+import           Control.Concurrent       (tryReadMVar, newEmptyMVar, tryPutMVar)
+import           Control.Monad            (unless)
 import qualified Data.ByteString.Lazy     as LBS
 import           Data.Proxy               (Proxy)
-import           Data.String              (IsString (..))
-import           Data.Text                (Text)
-import           GHC.Generics             (Generic)
 import qualified Network.HTTP.Client      as C
 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 (..),
+import           Test.QuickCheck          (Args (..),  Result (..), quickCheckWithResult)
-                                           quickCheckWithResult)
+import           Test.QuickCheck.Monadic  (assert, forAllM, monadicIO, monitor,
-import           Test.QuickCheck.Monadic  (assert, forAllM, monadicIO, run, monitor)
+                                           run)
 import           Test.QuickCheck.Property (counterexample)
-import Control.Monad (unless)
-import Control.Concurrent (newMVar, modifyMVar_, readMVar)
 
 import Servant.QuickCheck.Internal.Equality
+import Servant.QuickCheck.Internal.ErrorTypes
 import Servant.QuickCheck.Internal.HasGenRequest
 import Servant.QuickCheck.Internal.Predicates
-import Servant.QuickCheck.Internal.ErrorTypes
 
 
 -- | Start a servant application on an open port, run the provided function,
@@ -39,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 ->
@@ -57,29 +62,47 @@ withServantServerAndContext api ctx server t
 -- Evidently, if the behaviour of the server is expected to be
 -- non-deterministic,  this function may produce spurious failures
 --
+-- Note that only valid requests are generated and tested. As an example of why
+-- this matters, let's say your API specifies that a particular endpoint can
+-- only generate @JSON@. @serversEqual@ will then not generate any requests
+-- with an @Accept@ header _other_ than @application/json@. It may therefore
+-- fail to notice that one application, when the request has @Accept:
+-- text/html@, returns a @406 Not Acceptable@ HTTP response, and another
+-- returns a @200 Success@, but with @application/json@ as the content-type.
+--
+-- The fact that only valid requests are tested also means that no endpoints
+-- not listed in the API type are tested.
+--
 -- /Since 0.0.0.0/
 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 $
+      _ <- run $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
-        ServerEqualityFailure req1 resp1 resp2
       assert False
   case r of
     Success {} -> return ()
-    f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
+    Failure{..} -> do
-      "Failed:\n" ++ show x
+      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"
+    NoExpectedFailure {} -> expectationFailure "No expected failure"
-    InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
+#if MIN_VERSION_QuickCheck(2,12,0)
+#else
+    InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
+#endif
 
 -- | Check that a server satisfies the set of properties specified.
 --
@@ -102,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
+serverSatisfies api =  serverSatisfiesMgr api defManager
-  let reqs = ($ burl) <$> genRequest api
+
-  deetsMVar <- newMVar $ error "should not be called"
+-- | 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
+    v <- run $ finishPredicates preds (noCheckStatus req) manager
-     run $ modifyMVar_ deetsMVar $ const $ return v
+    _ <- run $ tryPutMVar deetsMVar v
-     case v of
+    case v of
-       Just x -> assert False
+      Just _ -> assert False
-       _ -> return ()
+      _ -> return ()
   case r of
     Success {} -> return ()
-    f@Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
+    Failure {..} -> do
-      "Failed:\n" ++ show x
+      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
+serverDoesntSatisfy api = serverDoesntSatisfyMgr api defManager
-  let reqs = ($ burl) <$> genRequest api
+
+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

stack.yaml

@@ -1,36 +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: nightly-2018-09-03
-resolver: nightly-2016-04-20
-
-# Local packages, usually specified by relative directory name
 packages:
 - '.'
-
-# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
 extra-deps:
-- servant-0.7
+- hspec-discover-2.5.6
-- servant-client-0.7
+- hspec-core-2.5.6
-- servant-server-0.7
+- hspec-2.5.6
-
+- QuickCheck-2.12
-# Override default flag values for local packages and extra-deps
 flags: {}
-
-# Extra package databases containing global packages
 extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: >= 1.0.0
-
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor

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

test/Servant/QuickCheck/InternalSpec.hs

@@ -1,20 +1,33 @@
 {-# LANGUAGE CPP #-}
 module Servant.QuickCheck.InternalSpec (spec) where
 
-import Control.Concurrent.MVar                    (newMVar, readMVar, swapMVar)
+
-import Control.Monad.IO.Class                     (liftIO)
+import           Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
-import Prelude.Compat
+import           Control.Exception       (SomeException)
-import Servant
+import           Control.Monad           (replicateM)
-import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPI)
+import           Control.Monad.IO.Class  (liftIO)
-import Test.Hspec                                 (Spec, context, describe, it,
+import qualified Data.ByteString         as BS
-                                                   pending, shouldBe,
+import qualified Data.ByteString.Char8   as C
-                                                   shouldContain)
+import           Data.Maybe              (fromJust)
-import Test.Hspec.Core.Spec                       (Arg, Example, Result (..),
+import           Network.HTTP.Client     (path, queryString)
-                                                   defaultParams,
+import           Prelude.Compat
-                                                   evaluateExample)
+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
@@ -22,6 +35,12 @@ spec = do
   serverSatisfiesSpec
   isComprehensiveSpec
   onlyJsonObjectSpec
+  notLongerThanSpec
+  queryParamsSpec
+  queryFlagsSpec
+  deepPathSpec
+  htmlDocTypesSpec
+  unbiasedGenerationSpec
 
 serversEqualSpec :: Spec
 serversEqualSpec = describe "serversEqual" $ do
@@ -32,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
@@ -62,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
+      FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
-        evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
+        evalExample $ serverSatisfies api burl args (notAllowedContainsAllowHeader <%> mempty)
-      err `shouldContain` "getsHaveCacheControlHeader"
+      show err `shouldContain` "notAllowedContainsAllowHeader"
-      err `shouldContain` "Headers"
+      show err `shouldContain` "Headers"
-      err `shouldContain` "Body"
+      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 comprehensiveAPI
+    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
@@ -97,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 ""
@@ -110,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 EvalResult
-evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
+evalExample e = do
-evalExample e = evaluateExample e defaultParams ($ ()) progCallback
+  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 }