Compare commits

..

No commits in common. "master" and "0.2.0.0" have entirely different histories.

17 changed files with 311 additions and 1099 deletions

1
.gitignore vendored
View File

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

View File

@ -1,158 +1,26 @@
# 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
sudo: false
language: c
os: linux
dist: xenial
git:
# whether to recursively clone submodules
submodules: false
branches:
only:
- master
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
cache:
directories:
- $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
- $HOME/.tinc/cache

View File

@ -1,174 +1,6 @@
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:

View File

@ -1,7 +0,0 @@
branches: master
constraint-set base-compat-0.10
constraints: base-compat ==0.10.*
constraint-set base-compat-0.11
constraints: base-compat ==0.11.*

View File

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

View File

@ -1,31 +0,0 @@
{-# 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)

View File

@ -1,22 +1,22 @@
name: servant-quickcheck
version: 0.0.9.1
synopsis: QuickCheck entire APIs
name: servant-quickcheck
version: 0.0.2.0
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
tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3
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
source-repository head
type: git
type: git
location: https://github.com/haskell-servant/servant-quickcheck
flag long-tests
@ -24,115 +24,82 @@ flag long-tests
default: False
library
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
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
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
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
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-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
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
if flag(long-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
cpp-options: -DLONG_TESTS

View File

@ -27,18 +27,12 @@ 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
@ -54,7 +48,6 @@ module Servant.QuickCheck
-- represents other means of checking equality
-- *** Useful @ResponseEquality@s
, bodyEquality
, jsonEquality
, allEquality
-- ** Response equality type
, ResponseEquality(..)

View File

@ -1,23 +1,16 @@
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
mappend = (<>)
ResponseEquality a `mappend` ResponseEquality b = ResponseEquality $ \x y ->
a x y && b x y
-- | Use `Eq` instance for `Response`
--
@ -30,29 +23,3 @@ 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

View File

@ -1,4 +1,3 @@
{-# LANGUAGE CPP #-}
module Servant.QuickCheck.Internal.ErrorTypes where
import Control.Exception (Exception (..))
@ -9,10 +8,9 @@ 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)

View File

@ -2,147 +2,112 @@
{-# 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, defaultRequest)
secure)
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, frequency)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Internal as BS (c2w)
import Test.QuickCheck (Arbitrary (..), Gen, elements, oneof)
-- -----------------------------------------------------------------------------
-- 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 -> (Int, Gen (BaseUrl -> Request))
genRequest :: Proxy a -> Gen (BaseUrl -> Request)
instance (HasGenRequest a, HasGenRequest b) => HasGenRequest (a :<|> b) where
genRequest _
= (lf + rf, frequency [l, r])
where
l@(lf, _) = genRequest (Proxy :: Proxy a)
r@(rf, _) = genRequest (Proxy :: Proxy b)
= oneof [ genRequest (Proxy :: Proxy a)
, genRequest (Proxy :: Proxy b)
]
instance (KnownSymbol path, HasGenRequest b) => HasGenRequest (path :> b) where
genRequest _ = (oldf, do
genRequest _ = do
old' <- old
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 })
return $ \burl -> let r = old' burl in r { path = new <> path r }
where
(oldf, old) = genRequest (Proxy :: Proxy b)
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' mods x c :> b) where
genRequest _ = (oldf, do
=> HasGenRequest (Capture x c :> b) where
genRequest _ = 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
(oldf, old) = genRequest (Proxy :: Proxy b)
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 _ = (oldf, do
genRequest _ = 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
(oldf, old) = genRequest (Proxy :: Proxy b)
old = genRequest (Proxy :: Proxy b)
new = arbitrary :: Gen [c]
#endif
instance (Arbitrary c, KnownSymbol h, HasGenRequest b, ToHttpApiData c)
=> HasGenRequest (Header' mods h c :> b) where
genRequest _ = (oldf, do
=> HasGenRequest (Header h c :> b) where
genRequest _ = do
old' <- old
new' <- toUrlPiece <$> new -- TODO: generate lenient or/and optional
new' <- toUrlPiece <$> new
return $ \burl -> let r = old' burl in r {
requestHeaders = (hdr, cs new') : requestHeaders r })
requestHeaders = (hdr, cs new') : requestHeaders r }
where
(oldf, old) = genRequest (Proxy :: Proxy b)
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' mods x c :> b) where
genRequest _ = (oldf, do
old' <- old -- TODO: generate lenient
=> HasGenRequest (ReqBody x c :> b) where
genRequest _ = do
old' <- old
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
(oldf, old) = genRequest (Proxy :: Proxy b)
old = genRequest (Proxy :: Proxy b)
new = arbitrary :: Gen c
instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
=> HasGenRequest (QueryParam' mods x c :> b) where
genRequest _ = (oldf, do
new' <- new -- TODO: generate lenient or/and optional
=> HasGenRequest (QueryParam x c :> b) where
genRequest _ = do
new' <- new
old' <- old
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 })
return $ \burl -> let r = old' burl in r {
queryString = queryString r
<> param <> "=" <> cs (toQueryParam new') }
where
(oldf, old) = genRequest (Proxy :: Proxy b)
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 _ = (oldf, do
genRequest _ = 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
(oldf, old) = genRequest (Proxy :: Proxy b)
old = genRequest (Proxy :: Proxy b)
param = cs $ symbolVal (Proxy :: Proxy x)
new = arbitrary :: Gen [c]
toParam c = param <> "[]=" <> cs (toQueryParam c)
@ -150,32 +115,22 @@ instance (KnownSymbol x, Arbitrary c, ToHttpApiData c, HasGenRequest b)
instance (KnownSymbol x, HasGenRequest b)
=> HasGenRequest (QueryFlag x :> b) where
genRequest _ = (oldf, do
genRequest _ = do
old' <- old
return $ \burl -> let r = old' burl
qs = queryString r in r {
queryString = if BS.null qs then param else param <> "&" <> qs })
return $ \burl -> let r = old' burl in r {
queryString = queryString r <> param <> "=" }
where
(oldf, old) = genRequest (Proxy :: Proxy b)
old = genRequest (Proxy :: Proxy b)
param = cs $ symbolVal (Proxy :: Proxy x)
instance (ReflectMethod method)
=> HasGenRequest (Verb (method :: k) (status :: Nat) (cts :: [*]) a) where
genRequest _ = (1, return $ \burl -> defaultRequest
genRequest _ = return $ \burl -> def
{ 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)

View File

@ -1,33 +1,26 @@
module Servant.QuickCheck.Internal.Predicates where
import Control.Exception (catch, throw)
import Control.Monad (liftM2, unless, when)
import Control.Monad (when, unless, liftM2)
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 (foldCase, foldedCase, mk)
import Data.CaseInsensitive (mk)
import Data.Either (isRight)
import Data.List.Split (wordsBy)
import Data.Maybe (fromMaybe, isJust)
import Data.Semigroup (Semigroup (..))
import qualified Data.Text as T
import Data.Time (UTCTime, defaultTimeLocale, parseTimeM,
rfc822DateFormat)
import Data.Monoid ((<>))
import GHC.Generics (Generic)
import Network.HTTP.Client (Manager, Request, Response, httpLbs,
method, parseRequest, requestHeaders,
responseBody, responseHeaders,
responseStatus)
method, requestHeaders, responseBody,
responseHeaders, parseRequest, 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
@ -43,23 +36,7 @@ import Servant.QuickCheck.Internal.ErrorTypes
-- /Since 0.0.0.0/
not500 :: ResponsePredicate
not500 = ResponsePredicate $ \resp ->
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 []
when (responseStatus resp == status500) $ fail "not500"
-- | [__Best Practice__]
--
@ -84,13 +61,9 @@ notLongerThan maxAllowed
-- /Since 0.0.0.0/
onlyJsonObjects :: ResponsePredicate
onlyJsonObjects
= 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 ())
= ResponsePredicate (\resp -> case decode (responseBody resp) of
Nothing -> throw $ PredicateFailure "onlyJsonObjects" Nothing resp
Just (_ :: Object) -> return ())
-- | __Optional__
--
@ -118,52 +91,21 @@ createContainsValidLocation
resp <- httpLbs req mgr
if responseStatus resp == status201
then case lookup "Location" $ responseHeaders resp of
Nothing -> throw $ PredicateFailure n (Just req) resp
Nothing -> fail n
Just l -> case parseRequest $ SBSC.unpack l of
Nothing -> throw $ PredicateFailure n (Just req) resp
Nothing -> fail n
Just x -> do
resp2 <- httpLbs x mgr
status2XX (Just req) resp2 n
status2XX resp2 n
return [resp, resp2]
else return [resp]
-- | [__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
= 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 []
= ResponsePredicate "getsHaveLastModifiedHeader" (\resp ->
-}
-- | [__RFC Compliance__]
--
@ -175,27 +117,23 @@ 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
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)
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
[] -> 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)
@ -225,7 +163,7 @@ honoursAcceptHeader
sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
if status100 < scode && scode < status300
then if isJust $ sctype >>= \x -> matchAccept [x] sacc
then throw $ PredicateFailure "honoursAcceptHeader" (Just req) resp
then fail "honoursAcceptHeader"
else return [resp]
else return [resp]
@ -336,29 +274,7 @@ unauthorizedContainsWWWAuthenticate
= ResponsePredicate $ \resp ->
if responseStatus resp == status401
then unless (hasValidHeader "WWW-Authenticate" (const True) resp) $
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
fail "unauthorizedContainsWWWAuthenticate"
else return ()
-- * Predicate logic
@ -372,47 +288,37 @@ htmlIncludesDoctype
-- | A predicate that depends only on the response.
--
-- /Since 0.0.0.0/
newtype ResponsePredicate = ResponsePredicate
data 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 ()
mappend = (<>)
ResponsePredicate a `mappend` ResponsePredicate b = ResponsePredicate $ \x -> a x >> b x
-- | A predicate that depends on both the request and the response.
--
-- /Since 0.0.0.0/
newtype RequestPredicate = RequestPredicate
{ getRequestPredicate :: Request -> Manager -> IO [Response LBS.ByteString]
data 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]))
mappend = (<>)
-- TODO: This isn't actually a monoid
instance Semigroup RequestPredicate where
RequestPredicate a <> RequestPredicate b = RequestPredicate $ \r mgr ->
RequestPredicate a `mappend` 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
mappend = (<>)
a `mappend` b = Predicates (requestPredicates a <> requestPredicates b)
(responsePredicates a <> responsePredicates b)
class JoinPreds a where
joinPreds :: a -> Predicates -> Predicates
@ -448,14 +354,8 @@ hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
Nothing -> False
Just v -> p v
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
status2XX :: Monad m => Response b -> String -> m ()
status2XX r t
| status200 <= responseStatus r && responseStatus r < status300
= return ()
| otherwise = throw $ PredicateFailure t mreq resp
| otherwise = fail t

View File

@ -1,8 +1,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
module Servant.QuickCheck.Internal.QuickCheck where
import Control.Concurrent (tryReadMVar, newEmptyMVar, tryPutMVar)
import Control.Concurrent (modifyMVar_, newMVar, readMVar)
import Control.Monad (unless)
import qualified Data.ByteString.Lazy as LBS
import Data.Proxy (Proxy)
@ -11,13 +10,11 @@ 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)
@ -40,11 +37,7 @@ 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 ->
@ -77,32 +70,25 @@ 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)) <$> runGenRequest api
let reqs = (\f -> (f burl1, f burl2)) <$> genRequest 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 <- newEmptyMVar
deetsMVar <- newMVar $ error "should not be called"
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 $ tryPutMVar deetsMVar $ ServerEqualityFailure req1 resp1 resp2
run $ modifyMVar_ deetsMVar $ const $ return $
ServerEqualityFailure req1 resp1 resp2
assert False
case r of
Success {} -> return ()
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
Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
"Failed:\n" ++ show x
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
NoExpectedFailure {} -> expectationFailure "No expected failure"
#if MIN_VERSION_QuickCheck(2,12,0)
#else
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
#endif
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
-- | Check that a server satisfies the set of properties specified.
--
@ -125,68 +111,40 @@ serversEqual api burl1 burl2 args req = do
-- /Since 0.0.0.0/
serverSatisfies :: (HasGenRequest a) =>
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
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
serverSatisfies api burl args preds = do
let reqs = ($ burl) <$> genRequest api
deetsMVar <- newMVar $ error "should not be called"
r <- quickCheckWithResult args { chatty = False } $ monadicIO $ forAllM reqs $ \req -> do
v <- run $ finishPredicates preds (noCheckStatus req) manager
_ <- run $ tryPutMVar deetsMVar v
case v of
Just _ -> assert False
_ -> return ()
v <- run $ finishPredicates preds (noCheckStatus req) defManager
run $ modifyMVar_ deetsMVar $ const $ return v
case v of
Just _ -> assert False
_ -> return ()
case r of
Success {} -> return ()
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
Failure{..} -> readMVar deetsMVar >>= \x -> expectationFailure $
"Failed:\n" ++ show x
GaveUp { numTests = n } -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
NoExpectedFailure {} -> expectationFailure $ "No expected failure"
#if MIN_VERSION_QuickCheck(2,12,0)
#else
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
#endif
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
serverDoesntSatisfy :: (HasGenRequest a) =>
Proxy a -> BaseUrl -> Args -> Predicates -> Expectation
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
serverDoesntSatisfy api burl args preds = do
let reqs = ($ burl) <$> genRequest api
r <- quickCheckWithResult args $ monadicIO $ forAllM reqs $ \req -> do
v <- run $ finishPredicates preds (noCheckStatus req) manager
v <- run $ finishPredicates preds (noCheckStatus req) defManager
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"
#if MIN_VERSION_QuickCheck(2,12,0)
#else
InsufficientCoverage {} -> expectationFailure "Insufficient coverage"
#endif
InsufficientCoverage {} -> expectationFailure $ "Insufficient coverage"
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

10
stack-ghc-8.0.1.yaml Normal file
View File

@ -0,0 +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-2016-09-07
packages:
- '.'
extra-deps:
- 'servant-0.8.1'
- 'servant-server-0.8.1'
- 'servant-client-0.8.1'
flags: {}
extra-package-dbs: []

View File

@ -1,10 +1,7 @@
resolver: nightly-2018-09-03
# 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
packages:
- '.'
extra-deps:
- hspec-discover-2.5.6
- hspec-core-2.5.6
- hspec-2.5.6
- QuickCheck-2.12
extra-deps: []
flags: {}
extra-package-dbs: []

44
test/Doctest.hs Normal file
View File

@ -0,0 +1,44 @@
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

View File

@ -1,33 +1,19 @@
{-# LANGUAGE CPP #-}
module Servant.QuickCheck.InternalSpec (spec) where
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 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 Servant.QuickCheck
import Servant.QuickCheck.Internal (genRequest, runGenRequest,
serverDoesntSatisfy)
import Servant.QuickCheck.Internal (genRequest, serverDoesntSatisfy)
spec :: Spec
spec = do
@ -35,12 +21,6 @@ spec = do
serverSatisfiesSpec
isComprehensiveSpec
onlyJsonObjectSpec
notLongerThanSpec
queryParamsSpec
queryFlagsSpec
deepPathSpec
htmlDocTypesSpec
unbiasedGenerationSpec
serversEqualSpec :: Spec
serversEqualSpec = describe "serversEqual" $ do
@ -51,42 +31,15 @@ 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
FailedWith err <- withServantServer api2 server2 $ \burl1 ->
Fail _ 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"
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"
show err `shouldContain` "Path: failplz/"
serverSatisfiesSpec :: Spec
serverSatisfiesSpec = describe "serverSatisfies" $ do
@ -108,123 +61,29 @@ serverSatisfiesSpec = describe "serverSatisfies" $ do
context "when predicates are false" $ do
it "fails with informative error messages" $ do
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"
Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies api burl args (getsHaveCacheControlHeader <%> mempty)
err `shouldContain` "getsHaveCacheControlHeader"
err `shouldContain` "Headers"
err `shouldContain` "Body"
onlyJsonObjectSpec :: Spec
onlyJsonObjectSpec = describe "onlyJsonObjects" $ do
it "fails correctly" $ do
FailedWith err <- withServantServerAndContext api ctx server $ \burl -> do
Fail _ err <- withServantServerAndContext api ctx server $ \burl -> do
evalExample $ serverSatisfies (Proxy :: Proxy (Get '[JSON] Int)) burl args
(onlyJsonObjects <%> mempty)
show err `shouldContain` "onlyJsonObjects"
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 comprehensiveAPIWithoutStreamingOrRaw
let _g = genRequest comprehensiveAPIWithoutRaw
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
@ -237,17 +96,6 @@ 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 ""
@ -261,105 +109,23 @@ 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 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"
evalExample :: (Example e, Arg e ~ ()) => e -> IO Result
evalExample e = evaluateExample e defaultParams ($ ()) progCallback
where
progCallback _ = return ()
data EvalResult
= AnException SomeException
| AllGood
| FailedWith String
deriving (Show)
args :: Args
args = defaultArgs { maxSuccess = noOfTestCases }