git.iko.soy/servant-quickcheck
on master help sign in
initial commit
commit72abea9b0f31c22076a93a7d0b728ca98645d943 authorJulian K. Arni <jkarni@gmail.com> dateFri 22 Apr 2016, 13:00 (10 years ago)
23 files changed+1752
.gitignore+1 .travis.yml+34 LICENSE+30 Setup.hs+2 doc/LICENSE+30 doc/Makefile+216 doc/ServersEqual.lhs+166 doc/Setup.hs+2 doc/conf.py+294 doc/doc.cabal+17 doc/index.rst+22 doc/requirements.txt+25 servant-quickcheck.cabal+88 src/Servant/QuickCheck.hs+94 src/Servant/QuickCheck/Internal.hs+6 src/Servant/QuickCheck/Internal/Benchmarking.hs+87 src/Servant/QuickCheck/Internal/Predicates.hs+132 src/Servant/QuickCheck/Internal/QuickCheck.hs+159 src/Servant/QuickCheck/Internal/Testable.hs+96 stack.yaml+36 test/Doctest.hs+44 test/Servant/CoMock/InternalSpec.hs+170 test/Spec.hs+1
.gitignorenew file+1
@@ -0,0 +1 @@
1+doc/_build/
.travis.ymlnew file+34
@@ -0,0 +1,34 @@
1+sudo: false
2+
3+language: c
4+
5+env:
6+ - GHCVER=7.8.4
7+ - GHCVER=7.10.2
8+
9+addons:
10+ apt:
11+ sources:
12+ - hvr-ghc
13+ packages:
14+ - ghc-7.8.4
15+ - ghc-7.10.2
16+ - cabal-install-1.22
17+ - libgmp-dev
18+ - wrk
19+
20+install:
21+ - (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
22+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
23+ - ghc --version
24+ - cabal --version
25+ - travis_retry cabal update
26+ - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
27+
28+script:
29+ - tinc && cabal configure --enable-tests && cabal build && cabal test
30+ - (cd doc && tinc cabal configure --enable-tests && cabal build && cabal test)
31+
32+cache:
33+ directories:
34+ - $HOME/.tinc/cache
LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2016, Julian K. Arni
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
doc/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2016, Julian K. Arni
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
doc/Makefilenew file+216
@@ -0,0 +1,216 @@
1+# Makefile for Sphinx documentation
2+#
3+
4+# You can set these variables from the command line.
5+SPHINXOPTS =
6+SPHINXBUILD = sphinx-build
7+PAPER =
8+BUILDDIR = _build
9+
10+# User-friendly check for sphinx-build
11+ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1)
12+$(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/)
13+endif
14+
15+# Internal variables.
16+PAPEROPT_a4 = -D latex_paper_size=a4
17+PAPEROPT_letter = -D latex_paper_size=letter
18+ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
19+# the i18n builder cannot share the environment and doctrees with the others
20+I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
21+
22+.PHONY: help
23+help:
24+ @echo "Please use \`make <target>' where <target> is one of"
25+ @echo " html to make standalone HTML files"
26+ @echo " dirhtml to make HTML files named index.html in directories"
27+ @echo " singlehtml to make a single large HTML file"
28+ @echo " pickle to make pickle files"
29+ @echo " json to make JSON files"
30+ @echo " htmlhelp to make HTML files and a HTML help project"
31+ @echo " qthelp to make HTML files and a qthelp project"
32+ @echo " applehelp to make an Apple Help Book"
33+ @echo " devhelp to make HTML files and a Devhelp project"
34+ @echo " epub to make an epub"
35+ @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
36+ @echo " latexpdf to make LaTeX files and run them through pdflatex"
37+ @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"
38+ @echo " text to make text files"
39+ @echo " man to make manual pages"
40+ @echo " texinfo to make Texinfo files"
41+ @echo " info to make Texinfo files and run them through makeinfo"
42+ @echo " gettext to make PO message catalogs"
43+ @echo " changes to make an overview of all changed/added/deprecated items"
44+ @echo " xml to make Docutils-native XML files"
45+ @echo " pseudoxml to make pseudoxml-XML files for display purposes"
46+ @echo " linkcheck to check all external links for integrity"
47+ @echo " doctest to run all doctests embedded in the documentation (if enabled)"
48+ @echo " coverage to run coverage check of the documentation (if enabled)"
49+
50+.PHONY: clean
51+clean:
52+ rm -rf $(BUILDDIR)/*
53+
54+.PHONY: html
55+html:
56+ $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
57+ @echo
58+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
59+
60+.PHONY: dirhtml
61+dirhtml:
62+ $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
63+ @echo
64+ @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
65+
66+.PHONY: singlehtml
67+singlehtml:
68+ $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
69+ @echo
70+ @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
71+
72+.PHONY: pickle
73+pickle:
74+ $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
75+ @echo
76+ @echo "Build finished; now you can process the pickle files."
77+
78+.PHONY: json
79+json:
80+ $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
81+ @echo
82+ @echo "Build finished; now you can process the JSON files."
83+
84+.PHONY: htmlhelp
85+htmlhelp:
86+ $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
87+ @echo
88+ @echo "Build finished; now you can run HTML Help Workshop with the" \
89+ ".hhp project file in $(BUILDDIR)/htmlhelp."
90+
91+.PHONY: qthelp
92+qthelp:
93+ $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
94+ @echo
95+ @echo "Build finished; now you can run "qcollectiongenerator" with the" \
96+ ".qhcp project file in $(BUILDDIR)/qthelp, like this:"
97+ @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/generics-eot.qhcp"
98+ @echo "To view the help file:"
99+ @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/generics-eot.qhc"
100+
101+.PHONY: applehelp
102+applehelp:
103+ $(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp
104+ @echo
105+ @echo "Build finished. The help book is in $(BUILDDIR)/applehelp."
106+ @echo "N.B. You won't be able to view it unless you put it in" \
107+ "~/Library/Documentation/Help or install it in your application" \
108+ "bundle."
109+
110+.PHONY: devhelp
111+devhelp:
112+ $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
113+ @echo
114+ @echo "Build finished."
115+ @echo "To view the help file:"
116+ @echo "# mkdir -p $$HOME/.local/share/devhelp/generics-eot"
117+ @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/generics-eot"
118+ @echo "# devhelp"
119+
120+.PHONY: epub
121+epub:
122+ $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
123+ @echo
124+ @echo "Build finished. The epub file is in $(BUILDDIR)/epub."
125+
126+.PHONY: latex
127+latex:
128+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
129+ @echo
130+ @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
131+ @echo "Run \`make' in that directory to run these through (pdf)latex" \
132+ "(use \`make latexpdf' here to do that automatically)."
133+
134+.PHONY: latexpdf
135+latexpdf:
136+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
137+ @echo "Running LaTeX files through pdflatex..."
138+ $(MAKE) -C $(BUILDDIR)/latex all-pdf
139+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
140+
141+.PHONY: latexpdfja
142+latexpdfja:
143+ $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
144+ @echo "Running LaTeX files through platex and dvipdfmx..."
145+ $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja
146+ @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
147+
148+.PHONY: text
149+text:
150+ $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
151+ @echo
152+ @echo "Build finished. The text files are in $(BUILDDIR)/text."
153+
154+.PHONY: man
155+man:
156+ $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
157+ @echo
158+ @echo "Build finished. The manual pages are in $(BUILDDIR)/man."
159+
160+.PHONY: texinfo
161+texinfo:
162+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
163+ @echo
164+ @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
165+ @echo "Run \`make' in that directory to run these through makeinfo" \
166+ "(use \`make info' here to do that automatically)."
167+
168+.PHONY: info
169+info:
170+ $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
171+ @echo "Running Texinfo files through makeinfo..."
172+ make -C $(BUILDDIR)/texinfo info
173+ @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
174+
175+.PHONY: gettext
176+gettext:
177+ $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
178+ @echo
179+ @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
180+
181+.PHONY: changes
182+changes:
183+ $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
184+ @echo
185+ @echo "The overview file is in $(BUILDDIR)/changes."
186+
187+.PHONY: linkcheck
188+linkcheck:
189+ $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
190+ @echo
191+ @echo "Link check complete; look for any errors in the above output " \
192+ "or in $(BUILDDIR)/linkcheck/output.txt."
193+
194+.PHONY: doctest
195+doctest:
196+ $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
197+ @echo "Testing of doctests in the sources finished, look at the " \
198+ "results in $(BUILDDIR)/doctest/output.txt."
199+
200+.PHONY: coverage
201+coverage:
202+ $(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage
203+ @echo "Testing of coverage in the sources finished, look at the " \
204+ "results in $(BUILDDIR)/coverage/python.txt."
205+
206+.PHONY: xml
207+xml:
208+ $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml
209+ @echo
210+ @echo "Build finished. The XML files are in $(BUILDDIR)/xml."
211+
212+.PHONY: pseudoxml
213+pseudoxml:
214+ $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml
215+ @echo
216+ @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."
doc/ServersEqual.lhsnew file+166
@@ -0,0 +1,166 @@
1+# Testing that servers behave identically
2+
3+## Rewriting an application
4+
5+If you are rewriting, or significantly refactoring, an application, you often
6+want to ensure that the behaviour of the rewritten application is the same as
7+that of the old one. Sometimes what the behaviour of the old application is is
8+not always clear, making the process a difficult and error-prone one.
9+
10+**servant-quickcheck** can help. It provides a `serversEqual` function that,
11+given a **servant** API type and two URLs, generates arbitrary requests of the
12+right type and checks that, for the same request *history*, the two servers
13+respond identically.
14+
15+To see how this works, let's re-implement the [Django
16+Todo-Backend](https://github.com/mihirk/todo-backend-django) application
17+in **servant**. (`serversEqual` works for non-**servant** applications, though
18+it's somewhat nicer to use when one of them is written with **servant**.) You
19+don't need to know anything about Django or Python to follow along; indeed,
20+part of the fun of it is using `serversEqual` to guide you through
21+re-implementing code you may not entirely understand.
22+
23+Looking at the code, we can see the routes in `urls.py`:
24+
25+``` python
26+urlpatterns = patterns('',
27+ url(r'^$', RedirectView.as_view(url='/todos')),
28+ url(r'^todos$', views.TodoList.as_view()),
29+ url(r'^todo/(?P<pk>[0-9]+)$', views.Todo.as_view()),
30+)
31+```
32+
33+And the handlers in `views.py`:
34+
35+``` python
36+class TodoList(APIView):
37+ def get(self, request, format=None):
38+ todo_items = TodoItem.objects.all()
39+ serializer = TodoItemSerializer(todo_items, many=True)
40+ return JSONResponse(serializer.data, status=status.HTTP_200_OK)
41+
42+ def post(self, request, format=None):
43+ serializer = TodoItemSerializer(data=request.DATA)
44+ if serializer.is_valid():
45+ saved_item = serializer.save()
46+ saved_item.url = request.build_absolute_uri('/todo/' + str(saved_item.id))
47+ saved_item.save()
48+ serializer = TodoItemSerializer(instance=saved_item)
49+ return JSONResponse(serializer.data, status=status.HTTP_201_CREATED)
50+ return JSONResponse(serializer.errors, status=status.HTTP_400_BAD_REQUEST)
51+
52+ def delete(self, request, format=None):
53+ TodoItem.objects.all().delete()
54+ return JSONResponse(None, status=status.HTTP_204_NO_CONTENT)
55+
56+class Todo(APIView):
57+ def get(self, request, pk, format=None):
58+ try:
59+ todoItem = TodoItem.objects.get(pk=pk)
60+ serializer = TodoItemSerializer(todoItem)
61+ except TodoItem.DoesNotExist:
62+ return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
63+ return JSONResponse(serializer.data, status=status.HTTP_200_OK)
64+
65+ def delete(self, request, pk, format=None):
66+ try:
67+ todoItem = TodoItem.objects.get(pk=pk)
68+ todoItem.delete()
69+ except TodoItem.DoesNotExist:
70+ return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
71+ return JSONResponse(None, status=status.HTTP_204_NO_CONTENT)
72+
73+ def patch(self, request, pk, format=None):
74+ try:
75+ todoItem = TodoItem.objects.get(pk=pk)
76+ except TodoItem.DoesNotExist:
77+ return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
78+ serializer = TodoItemSerializer(data=request.DATA, instance=todoItem, partial=True)
79+ if serializer.is_valid():
80+ serializer.save()
81+ return JSONResponse(serializer.data, status=status.HTTP_200_OK)
82+ return JSONResponse(serializer.errors, status=status.HTTP_400_BAD_REQUEST)
83+```
84+
85+And from `models.py`:
86+
87+``` python
88+
89+class TodoItem(models.Model):
90+ title = models.CharField(max_length=256, null=True, blank=True)
91+ completed = models.NullBooleanField(null=True, blank=True, default=False)
92+ url = models.CharField(max_length=256, null=True, blank=True)
93+ order = models.IntegerField(null=True, blank=True)
94+
95+```
96+
97+So as a first pass, let's try:
98+
99+``` haskell
100+{-# LANGUAGE DataKinds #-}
101+{-# LANGUAGE TypeOperators #-}
102+
103+import Servant
104+import Servant.QuickCheck
105+import STMContainers.Map as M
106+import GHC.Conc (atomically)
107+import Test.QuickCheck
108+
109+data Todo = Todo
110+ { title :: String
111+ , completed :: Bool
112+ , url :: String
113+ , order :: Int
114+ } deriving (Eq, Show, Read)
115+
116+type API = TodosAPI :<|> TodoAPI
117+
118+type TodosAPI
119+ = "todos" :>
120+ ( Get '[JSON] [Todo]
121+ :<|> ReqBody '[JSON] Todo :> Post '[JSON] ()
122+ :<|> Delete '[JSON] ())
123+
124+type TodoAPI
125+ = "todo" :> Capture "id " Int :>
126+ ( Get '[JSON] Todo
127+ :<|> ReqBody '[JSON] Todo :> Patch '[JSON] ()
128+ :<|> Delete '[JSON} ())
129+
130+serverTodos :: Server TodosAPI
131+serverTodos tvar = getTodos tvar
132+ :<|> postTodos tvar
133+ :<|> deleteAllTodos tvar
134+
135+serverTodo :: Server TodoAPI
136+serverTodo id' = getTodo tvar id'
137+ :<|> patchTodo tvar id'
138+ :<|> deleteTodo tvar id'
139+
140+getTodos :: Map Int Todo -> Handler [Todo]
141+getTodos m = liftIO . atomically . toList $ S.stream m
142+
143+postTodos :: Map Int Todo -> Todo -> Handler ()
144+postTodos m t = liftIO . atomically $ S.insert m t
145+
146+deleteTodos :: Map Int Todo -> Todo -> Handler ()
147+deleteTodos m t = liftIO . atomically $ S.insert m t
148+```
149+
150+(We're keeping the `Todo`s in memory for simplicity - if this were a production
151+ application, we'd likely want to use a database.)
152+
153+Notice that we split up the API into two sub-APIs. Partly this makes things
154+cleaner and more readable, but there's also a more concrete benefit: we can
155+start testing that **parts** of the API have been correctly rewritten without
156+implementing the entire server.
157+
158+In order to check how we're doing, we need to add an `Arbitrary` instance for
159+`Todo`:
160+
161+``` haskell
162+instance Arbitrary Todo where
163+ arbitrary = Todo <$> arbitrary <$> arbitrary <$> arbitrary <$> arbitrary
164+```
165+
166+
doc/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
doc/conf.pynew file+294
@@ -0,0 +1,294 @@
1+# -*- coding: utf-8 -*-
2+#
3+# servant documentation build configuration file, created by
4+# sphinx-quickstart on Mon Nov 23 13:24:36 2015.
5+#
6+# This file is execfile()d with the current directory set to its
7+# containing dir.
8+#
9+# Note that not all possible configuration values are present in this
10+# autogenerated file.
11+#
12+# All configuration values have a default; values that are commented out
13+# serve to show the default.
14+
15+import sys
16+import os
17+import shlex
18+from recommonmark.parser import CommonMarkParser
19+
20+# If extensions (or modules to document with autodoc) are in another directory,
21+# add these directories to sys.path here. If the directory is relative to the
22+# documentation root, use os.path.abspath to make it absolute, like shown here.
23+#sys.path.insert(0, os.path.abspath('.'))
24+
25+# -- General configuration ------------------------------------------------
26+
27+# If your documentation needs a minimal Sphinx version, state it here.
28+#needs_sphinx = '1.0'
29+
30+# Add any Sphinx extension module names here, as strings. They can be
31+# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
32+# ones.
33+extensions = []
34+
35+# Add any paths that contain templates here, relative to this directory.
36+templates_path = ['_templates']
37+
38+# The suffix(es) of source filenames.
39+# You can specify multiple suffix as a list of string:
40+source_suffix = ['.md', '.rst', '.lhs']
41+
42+# The encoding of source files.
43+#source_encoding = 'utf-8-sig'
44+
45+# The master toctree document.
46+master_doc = 'index'
47+
48+# General information about the project.
49+project = u'servant-quickcheck'
50+copyright = u'2016, Servant Contributors'
51+author = u'Servant Contributors'
52+
53+# The version info for the project you're documenting, acts as replacement for
54+# |version| and |release|, also used in various other places throughout the
55+# built documents.
56+#
57+# The short X.Y version.
58+# version = 'latest'
59+# The full version, including alpha/beta/rc tags.
60+# release = 'latest'
61+
62+# The language for content autogenerated by Sphinx. Refer to documentation
63+# for a list of supported languages.
64+#
65+# This is also used if you do content translation via gettext catalogs.
66+# Usually you set "language" from the command line for these cases.
67+language = None
68+
69+# There are two options for replacing |today|: either, you set today to some
70+# non-false value, then it is used:
71+#today = ''
72+# Else, today_fmt is used as the format for a strftime call.
73+#today_fmt = '%B %d, %Y'
74+
75+# List of patterns, relative to source directory, that match files and
76+# directories to ignore when looking for source files.
77+exclude_patterns = ['_build', 'venv']
78+
79+# The reST default role (used for this markup: `text`) to use for all
80+# documents.
81+#default_role = None
82+
83+# If true, '()' will be appended to :func: etc. cross-reference text.
84+#add_function_parentheses = True
85+
86+# If true, the current module name will be prepended to all description
87+# unit titles (such as .. function::).
88+#add_module_names = True
89+
90+# If true, sectionauthor and moduleauthor directives will be shown in the
91+# output. They are ignored by default.
92+#show_authors = False
93+
94+# The name of the Pygments (syntax highlighting) style to use.
95+pygments_style = 'sphinx'
96+
97+def setup(app):
98+ from sphinx.highlighting import lexers
99+ from pygments.lexers import HaskellLexer
100+ lexers['haskell ignore'] = HaskellLexer(stripnl=False)
101+
102+# A list of ignored prefixes for module index sorting.
103+#modindex_common_prefix = []
104+
105+# If true, keep warnings as "system message" paragraphs in the built documents.
106+#keep_warnings = False
107+
108+# If true, `todo` and `todoList` produce output, else they produce nothing.
109+todo_include_todos = False
110+
111+
112+# -- Options for HTML output ----------------------------------------------
113+
114+# The theme to use for HTML and HTML Help pages. See the documentation for
115+# a list of builtin themes.
116+html_theme = 'sphinx_rtd_theme'
117+
118+# Theme options are theme-specific and customize the look and feel of a theme
119+# further. For a list of options available for each theme, see the
120+# documentation.
121+#html_theme_options = {}
122+
123+# Add any paths that contain custom themes here, relative to this directory.
124+#html_theme_path = []
125+
126+# The name for this set of Sphinx documents. If None, it defaults to
127+# "<project> v<release> documentation".
128+#html_title = None
129+
130+# A shorter title for the navigation bar. Default is the same as html_title.
131+#html_short_title = None
132+
133+# The name of an image file (relative to this directory) to place at the top
134+# of the sidebar.
135+#html_logo = None
136+
137+# The name of an image file (within the static path) to use as favicon of the
138+# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
139+# pixels large.
140+#html_favicon = None
141+
142+# Add any paths that contain custom static files (such as style sheets) here,
143+# relative to this directory. They are copied after the builtin static files,
144+# so a file named "default.css" will overwrite the builtin "default.css".
145+html_static_path = ['_static']
146+
147+# Add any extra paths that contain custom files (such as robots.txt or
148+# .htaccess) here, relative to this directory. These files are copied
149+# directly to the root of the documentation.
150+#html_extra_path = []
151+
152+# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
153+# using the given strftime format.
154+#html_last_updated_fmt = '%b %d, %Y'
155+
156+# If true, SmartyPants will be used to convert quotes and dashes to
157+# typographically correct entities.
158+#html_use_smartypants = True
159+
160+# Custom sidebar templates, maps document names to template names.
161+#html_sidebars = {}
162+
163+# Additional templates that should be rendered to pages, maps page names to
164+# template names.
165+#html_additional_pages = {}
166+
167+# If false, no module index is generated.
168+#html_domain_indices = True
169+
170+# If false, no index is generated.
171+#html_use_index = True
172+
173+# If true, the index is split into individual pages for each letter.
174+#html_split_index = False
175+
176+# If true, links to the reST sources are added to the pages.
177+#html_show_sourcelink = True
178+
179+# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
180+#html_show_sphinx = True
181+
182+# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
183+#html_show_copyright = True
184+
185+# If true, an OpenSearch description file will be output, and all pages will
186+# contain a <link> tag referring to it. The value of this option must be the
187+# base URL from which the finished HTML is served.
188+#html_use_opensearch = ''
189+
190+# This is the file name suffix for HTML files (e.g. ".xhtml").
191+#html_file_suffix = None
192+
193+# Language to be used for generating the HTML full-text search index.
194+# Sphinx supports the following languages:
195+# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja'
196+# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr'
197+#html_search_language = 'en'
198+
199+# A dictionary with options for the search language support, empty by default.
200+# Now only 'ja' uses this config value
201+#html_search_options = {'type': 'default'}
202+
203+# The name of a javascript file (relative to the configuration directory) that
204+# implements a search results scorer. If empty, the default will be used.
205+#html_search_scorer = 'scorer.js'
206+
207+# Output file base name for HTML help builder.
208+htmlhelp_basename = 'servantdoc'
209+
210+# -- Options for LaTeX output ---------------------------------------------
211+
212+latex_elements = {
213+# The paper size ('letterpaper' or 'a4paper').
214+#'papersize': 'letterpaper',
215+
216+# The font size ('10pt', '11pt' or '12pt').
217+#'pointsize': '10pt',
218+
219+# Additional stuff for the LaTeX preamble.
220+#'preamble': '',
221+
222+# Latex figure (float) alignment
223+#'figure_align': 'htbp',
224+}
225+
226+# Grouping the document tree into LaTeX files. List of tuples
227+# (source start file, target name, title,
228+# author, documentclass [howto, manual, or own class]).
229+latex_documents = [
230+ (master_doc, 'servant-quickcheck.tex', u'servant-quickcheck Documentation',
231+ u'Servant Contributors', 'manual'),
232+]
233+
234+# The name of an image file (relative to this directory) to place at the top of
235+# the title page.
236+#latex_logo = None
237+
238+# For "manual" documents, if this is true, then toplevel headings are parts,
239+# not chapters.
240+#latex_use_parts = False
241+
242+# If true, show page references after internal links.
243+#latex_show_pagerefs = False
244+
245+# If true, show URL addresses after external links.
246+#latex_show_urls = False
247+
248+# Documents to append as an appendix to all manuals.
249+#latex_appendices = []
250+
251+# If false, no module index is generated.
252+#latex_domain_indices = True
253+
254+
255+# -- Options for manual page output ---------------------------------------
256+
257+# One entry per manual page. List of tuples
258+# (source start file, name, description, authors, manual section).
259+man_pages = [
260+ (master_doc, 'servant-quickcheck', u'servant-quickcheck Documentation',
261+ [author], 1)
262+]
263+
264+# If true, show URL addresses after external links.
265+#man_show_urls = False
266+
267+
268+# -- Options for Texinfo output -------------------------------------------
269+
270+# Grouping the document tree into Texinfo files. List of tuples
271+# (source start file, target name, title, author,
272+# dir menu entry, description, category)
273+texinfo_documents = [
274+ (master_doc, 'servant-quickcheck', u'servant-quickcheck Documentation',
275+ author, 'servant-quickcheck', 'One line description of project.',
276+ 'Miscellaneous'),
277+]
278+
279+# Documents to append as an appendix to all manuals.
280+#texinfo_appendices = []
281+
282+# If false, no module index is generated.
283+#texinfo_domain_indices = True
284+
285+# How to display URL addresses: 'footnote', 'no', or 'inline'.
286+#texinfo_show_urls = 'footnote'
287+
288+# If true, do not generate a @detailmenu in the "Top" node's menu.
289+#texinfo_no_detailmenu = False
290+
291+source_parsers = {
292+ '.md': CommonMarkParser,
293+ '.lhs': CommonMarkParser,
294+}
doc/doc.cabalnew file+17
@@ -0,0 +1,17 @@
1+name: doc
2+version: 0.1.0.0
3+license: BSD3
4+license-file: LICENSE
5+author: Julian K. Arni
6+maintainer: jkarni@gmail.com
7+build-type: Simple
8+cabal-version: >=1.10
9+
10+library
11+ exposed-modules: ServersEqual
12+ other-extensions: DataKinds, TypeOperators
13+ build-depends: base >=4.8 && <4.9
14+ , servant-server == 0.7.*
15+
16+ ghc-options: -Wall -Werror -pgmL markdown-unlit
17+ default-language: Haskell2010
doc/index.rstnew file+22
@@ -0,0 +1,22 @@
1+servant-quickcheck – QuickCheck entire APIs
2+============================================
3+
4+**servant-quickcheck** provides ways of observing and testing the behaviour of
5+webservers under arbitrary, but sensible, requests. ('Sensible' here means
6+requests which have the correct type for their arguments (captures, query
7+params, headers, and request bodies).)
8+
9+**servant-quickcheck** can currently:
10+
11+ - Test whether two servers behave identically when provided the same inputs
12+ in the same order;
13+ - Test whether certain properties hold true of an entire API (e.g. that an
14+ API never throws a 500 error);
15+ - Stress test arbitrary endpoints in an API.
16+
17+.. toctree::
18+ :maxdepth: 1
19+
20+ ServersEqual.lhs
21+ ServerSatisfies.lhs
22+ ServerBenchmark.lhs
doc/requirements.txtnew file+25
@@ -0,0 +1,25 @@
1+alabaster==0.7.7
2+argh==0.26.1
3+Babel==2.2.0
4+backports-abc==0.4
5+backports.ssl-match-hostname==3.5.0.1
6+certifi==2015.11.20.1
7+CommonMark==0.5.4
8+docutils==0.12
9+Jinja2==2.8
10+livereload==2.4.1
11+MarkupSafe==0.23
12+pathtools==0.1.2
13+Pygments==2.1.1
14+pytz==2015.7
15+PyYAML==3.11
16+recommonmark==0.4.0
17+singledispatch==3.4.0.3
18+six==1.10.0
19+snowballstemmer==1.2.1
20+Sphinx==1.3.4
21+sphinx-autobuild==0.5.2
22+sphinx-rtd-theme==0.1.9
23+tornado==4.3
24+watchdog==0.8.3
25+wheel==0.26.0
servant-quickcheck.cabalnew file+88
@@ -0,0 +1,88 @@
1+name: servant-quickcheck
2+version: 0.1.0.0
3+synopsis: QuickCheck entire APIs
4+description:
5+ This packages provides QuickCheck properties that are tested across an entire
6+ API.
7+
8+license: BSD3
9+license-file: LICENSE
10+author: Julian K. Arni
11+maintainer: jkarni@gmail.com
12+category: Web
13+build-type: Simple
14+cabal-version: >=1.10
15+
16+flag long-tests
17+ description: Run more QuickCheck tests
18+ default: False
19+
20+library
21+ exposed-modules: Servant.QuickCheck
22+ , Servant.QuickCheck.Internal
23+ , Servant.QuickCheck.Internal.Benchmarking
24+ , Servant.QuickCheck.Internal.Predicates
25+ , Servant.QuickCheck.Internal.Testable
26+ , Servant.QuickCheck.Internal.QuickCheck
27+ build-depends: base >=4.8 && <4.9
28+ , QuickCheck == 2.8.*
29+ , bytestring == 0.10.*
30+ , aeson > 0.10 && < 0.12
31+ , mtl == 2.2.*
32+ , http-client == 0.4.*
33+ , http-types == 0.9.*
34+ , servant-client == 0.7.*
35+ , servant-server == 0.7.*
36+ , servant == 0.7.*
37+ , warp >= 3.2.4 && < 3.3
38+ , process == 1.2.*
39+ , temporary == 1.2.*
40+ , hspec
41+ hs-source-dirs: src
42+ default-extensions: TypeOperators
43+ , FlexibleInstances
44+ , FlexibleContexts
45+ , DataKinds
46+ , GADTs
47+ , MultiParamTypeClasses
48+ , DeriveFunctor
49+ , RankNTypes
50+ , ConstraintKinds
51+ , DeriveGeneric
52+ default-language: Haskell2010
53+
54+test-suite spec
55+ type: exitcode-stdio-1.0
56+ ghc-options: -Wall -O2 -threaded
57+ default-language: Haskell2010
58+ hs-source-dirs: test
59+ main-is: Spec.hs
60+ other-modules: Servant.QuickCheck.InternalSpec
61+ build-depends: base == 4.*
62+ , servant-quickcheck
63+ , hspec
64+ , http-client
65+ , warp
66+ , servant-server
67+ , servant-client
68+ , transformers
69+ , QuickCheck
70+ default-extensions: TypeOperators
71+ , FlexibleInstances
72+ , FlexibleContexts
73+ , DataKinds
74+ if flag(long-tests)
75+ cpp-options: -DLONG_TESTS
76+
77+-- test-suite doctests
78+-- default-language: Haskell2010
79+-- type: exitcode-stdio-1.0
80+-- ghc-options: -threaded
81+-- main-is: Doctest.hs
82+-- hs-source-dirs: test
83+-- build-depends: base >4 && <5
84+-- , doctest
85+-- , filemanip
86+-- , directory
87+-- , filepath
88+-- HS-Source-Dirs: test
src/Servant/QuickCheck.hsnew file+94
@@ -0,0 +1,94 @@
1+-- | @Servant.QuickCheck@ provides utilities related to using QuickCheck over an API.
2+-- Rather than specifying properties that individual handlers must satisfy,
3+-- you can state properties that ought to hold true of the entire API.
4+--
5+-- While the API must be described with @servant@ types, the server being
6+-- tested itself need not be implemented with @servant-server@ (or indeed,
7+-- written in Haskell).
8+--
9+-- /N.B./ The examples given here assume the following setup:
10+--
11+-- > import Servant
12+-- > import Servant.QuickCheck
13+-- > import Test.Hspec
14+-- >
15+-- > type API = ReqBody '[JSON] Int :> Post '[JSON] String
16+-- >
17+-- > api :: Proxy API
18+-- > api = Proxy
19+module Servant.QuickCheck
20+ (
21+
22+ -- * Server properties
23+ -- | Functions to verify that a server meets certain properties.
24+ --
25+ -- Example:
26+ --
27+ -- > server :: Server API
28+ -- > server = return . show
29+ -- >
30+ -- >
31+ -- > test :: Spec
32+ -- > test = describe "my server" $ do
33+ -- >
34+ -- > it "never throws a 500 on valid input" $ do
35+ -- > withServantServer api server $ \url ->
36+ -- > serverSatisfiers api url emptyPredicates never500s 100
37+ serverSatisfies
38+
39+ -- * Server equality
40+ -- | Functions to verify that two servers behave identically.
41+ --
42+ -- This can be useful when for example rewriting or refactoring an
43+ -- application.
44+ --
45+ -- Example:
46+ --
47+ -- > server :: Server API
48+ -- > server = return . show
49+ -- >
50+ -- > server2 :: Server API
51+ -- > server2 = const $ return "hi"
52+ -- >
53+ -- > test :: Spec
54+ -- > test = describe "my new server" $ do
55+ -- >
56+ -- > it "behaves like the old one" $ do
57+ -- > withServantServer api server $ \url1 ->
58+ -- > withServantServer api server2 $ \url2 ->
59+ -- > serversEqual api url1 url2 100
60+ --
61+ , serversEqual
62+
63+ -- * Server benchmarking
64+ -- | Functions that randomly generate and run benchmarking scripts
65+ , serverBenchmark
66+ , BenchOptions(..)
67+ , defaultBenchOptions
68+
69+
70+ -- * Test setup helpers
71+ -- | Helpers to setup and teardown @servant@ servers during tests.
72+ , withServantServer
73+
74+ -- * Predicates
75+ -- | Predicates (functions with signatures @a -> Bool@) are used to filter
76+ -- out QuickCheck-generated values (so as to specify that requests must
77+ -- possess certain properties) and to check that the response specifies the
78+ -- expected properties.
79+ , Predicates
80+ , emptyPredicates
81+ , addPredicate
82+ , addPolyPredicate
83+
84+ -- ** Predicate convenience functions
85+ , addRightPredicate
86+ , addLeftPredicate
87+
88+ -- ** Useful predicates
89+ , never500s
90+ , onlyJsonObjects
91+
92+ ) where
93+
94+import Servant.QuickCheck.Internal
src/Servant/QuickCheck/Internal.hsnew file+6
@@ -0,0 +1,6 @@
1+module Servant.QuickCheck.Internal (module X) where
2+
3+import Servant.QuickCheck.Internal.Testable as X
4+import Servant.QuickCheck.Internal.Predicates as X
5+import Servant.QuickCheck.Internal.QuickCheck as X
6+import Servant.QuickCheck.Internal.Benchmarking as X
src/Servant/QuickCheck/Internal/Benchmarking.hsnew file+87
@@ -0,0 +1,87 @@
1+-- | This module contains benchmark-related logic.
2+--
3+-- Currently it generates 'wrk' scripts rather than benchmarking directly with
4+-- the @servant-client@ functions since the performance of 'wrk' is
5+-- significantly better.
6+module Servant.QuickCheck.Internal.Benchmarking where
7+
8+import Data.ByteString (ByteString)
9+import Data.ByteString.Lazy (toStrict)
10+import Network.HTTP.Client
11+import Network.HTTP.Types
12+import Servant.Client
13+
14+data BenchOptions = BenchOptions
15+ { duration :: Int
16+ , threads :: Int
17+ , connections :: Int
18+ , noOfTests :: Int
19+ } deriving (Eq, Show, Read)
20+
21+defaultBenchOptions :: BenchOptions
22+defaultBenchOptions = BenchOptions
23+ { duration = 10
24+ , threads = 1
25+ , connections = 10
26+ , noOfTests = 10
27+ }
28+
29+data WrkScript = WrkScript
30+ { wrkScheme :: Scheme
31+ , wrkHost :: ByteString
32+ , wrkPort :: Int
33+ , wrkMethod :: Method
34+ , wrkPath :: ByteString
35+ , wrkHeaders :: [Header]
36+ , wrkBody :: ByteString
37+ } deriving (Eq, Show)
38+
39+mkScript :: WrkScript -> String
40+mkScript w
41+ = "wrk.scheme = \"" ++ sscheme (wrkScheme w) ++ "\""
42+ ++ "\nwrk.host = " ++ show (wrkHost w)
43+ ++ "\nwrk.port = " ++ show (wrkPort w)
44+ ++ "\nwrk.method = " ++ show (wrkMethod w)
45+ ++ "\nwrk.path = " ++ show (wrkPath w)
46+ ++ foldr (\(h,v) old -> old ++ "\nwrk.headers[" ++ show h ++ "] = " ++ show v)
47+ ""
48+ (wrkHeaders w)
49+ ++ "\nwrk.body = " ++ show (wrkBody w)
50+ ++ "\n" ++ reportFmt
51+ where
52+ sscheme Http = "http"
53+ sscheme Https = "https"
54+
55+reqToWrk :: Request -> WrkScript
56+reqToWrk r = WrkScript
57+ { wrkScheme = Http
58+ , wrkHost = host r
59+ , wrkPort = port r
60+ , wrkMethod = method r
61+ , wrkPath = path r
62+ , wrkHeaders = requestHeaders r
63+ , wrkBody = case requestBody r of
64+ RequestBodyLBS r' -> toStrict r'
65+ _ -> error "expecting RequestBodyLBS"
66+ }
67+
68+reportFmt :: String
69+reportFmt
70+ = "done = function(summary, latency, requests)\n"
71+ ++ " for _, p in pairs({ 50, 75, 99, 99.999 }) do\n"
72+ ++ " n = latency:percentile(p)\n"
73+ ++ " io.write(string.format(\"%g%%, %d\\n\", p, n))\n"
74+ ++ " end\n"
75+ ++ "end\n"
76+
77+{-data BenchResult = BenchResult-}
78+ {-{ benchReq :: Request-}
79+ {-, benchLatencyDist :: [(Percentile, Microsecs)]-}
80+ {-, benchLatencyAvg :: Microsecs-}
81+ {-} deriving (Eq, Show, Read, Generic)-}
82+
83+{-newtype Microsecs = Microsecs { unMicroSecs :: Int }-}
84+ {-deriving (Eq, Show, Read, Generic)-}
85+
86+{-newtype Percentile = Percentile { unPercentile :: Int }-}
87+ {-deriving (Eq, Show, Read, Generic)-}
src/Servant/QuickCheck/Internal/Predicates.hsnew file+132
@@ -0,0 +1,132 @@
1+-- | This module contains all logic related to constructing or using
2+-- @Predicates@.
3+{-# LANGUAGE UndecidableInstances #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+module Servant.QuickCheck.Internal.Predicates where
6+
7+import Data.Aeson (ToJSON (toJSON), Value (..))
8+import Data.Proxy (Proxy (..))
9+import Data.Void
10+import Network.HTTP.Types (statusCode)
11+import Servant.Common.Req (ServantError (..))
12+import Test.QuickCheck
13+
14+
15+-- | An HList containing predicates (functions of type @a -> Bool@). This
16+-- datatype is used to represent both filters (what values to discard when
17+-- generating arguments to test an API) and tests results (what to consider a
18+-- failing response).
19+--
20+-- For both filters and test results, only the *first* predicate of the
21+-- appropriate type is used.
22+--
23+-- Use 'emptyPredicates', 'addPredicate', 'addLeftPredicate' and
24+-- 'addRightPredicate' to construct a @Predicates@.
25+data Predicates a where
26+ HNil :: Predicates '[]
27+ HCons :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
28+ HConsC :: Constraint a -> Predicates b -> Predicates (Constraint a ': b)
29+
30+class HasPredicate a b where
31+ getPredicate :: Predicates a -> b -> Bool
32+
33+instance {-# OVERLAPPING #-} HasPredicate '[] a where
34+ getPredicate _ = const True
35+
36+-- TODO: Find some better way of distinguishing how the predicate is being used
37+instance {-# OVERLAPPING #-} HasPredicate '[] (Either ServantError a) where
38+ getPredicate _ = discard
39+
40+instance {-# OVERLAPPING #-} HasPredicate (a ': xs) a where
41+ getPredicate (HCons a _) = a
42+ getPredicate (HConsC _ _) = error "not impossible, but non-sensical"
43+
44+data Constraint ctx = Constraint
45+ { getConstraint :: forall a . (ctx a) => a -> Bool }
46+
47+-- This is a little bit of a hack. Ideally instances would match when the
48+-- predicate is polymorphic, but that doesn't work since the polymorphic type
49+-- may have to unify with multiple distict values.
50+--
51+-- It may however be possible to define a MPTC from monomorphic to polymorphic
52+-- datatypes to avoid this issue.
53+instance {-# OVERLAPPING #-}
54+ HasPredicate (Either ServantError Void ': xs) (Either ServantError a) where
55+ getPredicate (HCons f _) x = case x of
56+ Left e -> f (Left e)
57+ Right _ -> True
58+
59+instance {-# OVERLAPPING #-} (ctx a)
60+ => HasPredicate (Constraint ctx ': xs) (Either ServantError a) where
61+ getPredicate (HConsC f _) x = case x of
62+ Left _ -> discard -- Not clear whether checking for FailureResponse is better
63+ Right v -> getConstraint f v
64+ getPredicate (HCons _ _) _ = error "not impossible, but non-sensical"
65+
66+instance {-# OVERLAPPABLE #-} (ls ~ (b ': xs), HasPredicate xs a)
67+ => HasPredicate ls a where
68+ getPredicate (HCons _ xs) = getPredicate xs
69+ getPredicate _ = error "impossible"
70+
71+-- | Add a predicate to a list of predicates. Note that the predicate may not
72+-- be polymorphic.
73+addPredicate :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
74+addPredicate = HCons
75+
76+-- | Add a predicate with a class constraint.
77+--
78+-- Note that every possible argument must be an instance of that class for this
79+-- to typecheck. In other words, if the @Predicates@ is being used for return
80+-- types, every return type in the API must be an instance of the class. If
81+-- it's being used for filtering, every capture, header, body, etc. type must
82+-- be an instance of that class.
83+--
84+-- This can be used to for example test that returned JSON has certain
85+-- properties, or (via generics) that if any datatype contains a (possibly
86+-- nested) field of a particular type, it always meets certain properties.
87+addPolyPredicate :: proxy ctx -> (forall a. ctx a => a -> Bool) -> Predicates b
88+ -> Predicates (Constraint ctx ': b)
89+addPolyPredicate _ p = HConsC (Constraint p)
90+
91+-- | Given a predicate over an @p :: a -> Bool@, add a predicate to the @Predicates@
92+-- list that succeeds on an @val :: Either ServantError a@ if @val@ is a
93+-- @Left@, or a @Right v@ such that @p a == True@.
94+addRightPredicate :: (a -> Bool) -> Predicates b -> Predicates (Either ServantError a ': b)
95+addRightPredicate p = addPredicate $ either (const True) p
96+
97+-- | The @Left@ analog of 'addRightPredicate'.
98+addLeftPredicate :: (ServantError -> Bool) -> Predicates b
99+ -> Predicates (Either ServantError Void ': b)
100+addLeftPredicate p = addPredicate $ either p (error "impossible")
101+
102+-- | An empty list of predicates. This doesn't discard any values when used as
103+-- a filter, and doesn't fail any value when used as a condition to satisfy.
104+emptyPredicates :: Predicates '[]
105+emptyPredicates = HNil
106+
107+-- * Useful predicates
108+
109+-- | A @Predicates@ list that fails a test if the response is an HTTP 500 error.
110+never500s :: Predicates '[Either ServantError Void]
111+never500s = addLeftPredicate go emptyPredicates
112+ where
113+ go (FailureResponse x _ _) = statusCode x /= 500
114+ go _ = True
115+
116+-- | A @Predicates@ list that fails a test if the response is anything but a
117+-- top-level object (e.g., if it is an array or literal).
118+--
119+-- Returning anything other than object is considered bad practice, as
120+--
121+-- (1) it is hard to modify the returned value while maintaining backwards
122+-- compatibility;
123+-- (2) many older tools do not support top-level arrays;
124+-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
125+-- on what RFC you're going by;
126+-- (4) there are security issues with top-level arrays.
127+onlyJsonObjects :: Predicates '[Constraint ToJSON]
128+onlyJsonObjects = addPolyPredicate (Proxy :: Proxy ToJSON) go emptyPredicates
129+ where
130+ go x = case toJSON x of
131+ Object _ -> True
132+ _ -> False
src/Servant/QuickCheck/Internal/QuickCheck.hsnew file+159
@@ -0,0 +1,159 @@
1+-- | This module contains wrappers around lower-level functionality.
2+module Servant.QuickCheck.Internal.QuickCheck where
3+
4+import Control.Concurrent (threadDelay)
5+import Control.Concurrent.MVar (modifyMVar_, readMVar)
6+import Control.Monad (replicateM_)
7+import Data.Proxy (Proxy)
8+import Data.Void (Void)
9+import Network.HTTP.Client (Manager, defaultManagerSettings,
10+ newManager)
11+import Network.HTTP.Client (managerModifyRequest, getUri)
12+import Network.Wai.Handler.Warp (withApplication)
13+import Servant (HasServer, Server, serve)
14+import Servant.Client (BaseUrl (..), Client, HasClient,
15+ Scheme (..), ServantError, client)
16+import System.IO (hPutStrLn, hFlush)
17+import System.IO.Temp (withSystemTempFile)
18+import System.Mem (performGC)
19+import System.Process (callCommand)
20+import Test.Hspec (Expectation, expectationFailure)
21+import Test.QuickCheck (Args (..), Property, Result (..),
22+ Testable, property,
23+ quickCheckWithResult, stdArgs)
24+
25+import Servant.QuickCheck.Internal.Testable
26+import Servant.QuickCheck.Internal.Predicates
27+import Servant.QuickCheck.Internal.Benchmarking
28+
29+
30+-- | Start a servant application on an open port, run the provided function,
31+-- then stop the application.
32+withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
33+ -> (BaseUrl -> IO r) -> IO r
34+withServantServer api server t
35+ = withApplication (return . serve api =<< server) $ \port ->
36+ t (BaseUrl Http "localhost" port "")
37+
38+-- | A QuickCheck 'Property' that randomly generates arguments (captures, query
39+-- params, request bodies, headers, etc.) expected by endpoints of a server,
40+-- and makes requests to the servers running in the two provided URLs in the
41+-- same order, failing if they do not return the same response.
42+--
43+-- Evidently, if the behaviour of the server is expected to be
44+-- non-deterministic, this function may produce spurious failures.
45+--
46+-- Note that this QuickCheck 'Property' does IO; interleaving it with other IO
47+-- actions will not work. It is provided so that it can be used with QuickCheck
48+-- functions such as 'quickCheckWith'. For most use cases, you should use
49+-- @serversEqual@ or @servantServersEqual@.
50+serversEqualProperty :: (HasClient a, Testable (ShouldMatch (Client a)))
51+ => Proxy a -> Manager -> BaseUrl -> BaseUrl -> Property
52+serversEqualProperty api mgr burl1 burl2 = property $ ShouldMatch c1 c2
53+ where c1 = client api burl1 mgr
54+ c2 = client api burl2 mgr
55+
56+-- | Check that the two servers running under the provided @BaseUrl@s behave
57+-- identically by randomly generating arguments (captures, query params, request bodies,
58+-- headers, etc.) expected by the server. If, given the same request, the
59+-- response is not the same (according to the definition of @==@ for the return
60+-- datatype), the 'Expectation' fails, printing the counterexample.
61+--
62+-- The @Int@ argument specifies maximum number of test cases to generate and
63+-- run.
64+--
65+-- Evidently, if the behaviour of the server is expected to be
66+-- non-deterministic, this function may produce spurious failures.
67+serversEqual :: (HasClient a, Testable (ShouldMatch (Client a)))
68+ => Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
69+serversEqual api burl1 burl2 tries = do
70+ mgr <- managerWithStoredReq
71+ let args = stdArgs { chatty = False, maxSuccess = tries }
72+ res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
73+ case res of
74+ Success _ _ _ -> return ()
75+ _ -> prettyErr >>= expectationFailure
76+
77+
78+serverSatisfiesProperty :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
79+ => Proxy a -> Manager -> BaseUrl -> Predicates filt -> Predicates exp -> Property
80+serverSatisfiesProperty api mgr burl filters expect = do
81+ property $ ShouldSatisfy (client api burl mgr) filters expect
82+
83+-- | Check that a server's responses satisfies certain properties.
84+serverSatisfies :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
85+ => Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
86+ -> Int -> Expectation
87+serverSatisfies api burl filters expect tries = do
88+ mgr <- managerWithStoredReq
89+ let args = stdArgs { chatty = False, maxSuccess = tries }
90+ res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
91+ case res of
92+ Success _ _ _ -> return ()
93+ GaveUp n _ _ -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
94+ _ -> prettyErr >>= expectationFailure
95+
96+-- | Check that the two servers running under the provided @BaseUrl@s do not
97+-- behave identically.
98+--
99+-- As with @serversEqualProperty@, non-determinism in the servers will likely
100+-- result in failures that may not be significant.
101+serversUnequal :: (HasClient a, Testable (ShouldMatch (Client a)))
102+ => Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
103+serversUnequal api burl1 burl2 tries = do
104+ mgr <- managerWithStoredReq
105+ let args = stdArgs { chatty = False, maxSuccess = tries }
106+ res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
107+ case res of
108+ Success _ _ _ -> prettyErr >>= expectationFailure
109+ _ -> return ()
110+
111+serverDoesntSatisfy :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
112+ => Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
113+ -> Int -> Expectation
114+serverDoesntSatisfy api burl filters expect tries = do
115+ mgr <- managerWithStoredReq
116+ let args = stdArgs { chatty = False, maxSuccess = tries }
117+ res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
118+ case res of
119+ Success _ _ _ -> prettyErr >>= expectationFailure
120+ _ -> return ()
121+
122+-- | Benchmarks a server with arbitrary requests using 'wrk'.
123+--
124+-- When using this, you should compile your program with '-threaded'.
125+-- Moreover, 'wrk' must be in the @$PATH@.
126+--
127+-- Note that this function is still very experimental, and it's behaviour will
128+-- likely change.
129+serverBenchmark ::
130+ (HasClient a , Testable (ShouldSatisfy '[] '[Either ServantError Void] (Client a)))
131+ => Proxy a -> BaseUrl -> BenchOptions -> IO ()
132+serverBenchmark api burl opts = replicateM_ (noOfTests opts) go
133+ where
134+ go = do
135+ let alwaysTrue = addLeftPredicate (const True) emptyPredicates
136+ serverSatisfies api burl emptyPredicates alwaysTrue 1
137+ Just (r, _) <- readMVar currentReq
138+ withSystemTempFile "wrkscript.lua" $ \f h -> do
139+ let url = show $ getUri r
140+ s = mkScript $ reqToWrk r
141+ c = "wrk -c" ++ show (connections opts)
142+ ++ " -d" ++ show (duration opts) ++ "s "
143+ ++ " -t" ++ show (threads opts)
144+ ++ " -s \"" ++ f ++ "\" "
145+ ++ " --latency "
146+ ++ url
147+ hPutStrLn h s
148+ hFlush h
149+ callCommand c
150+ -- While running wrk and the server on the same machine make the
151+ -- results much less meaningful, this ameliorates the situation
152+ -- somewhat.
153+ performGC
154+ threadDelay 1000
155+
156+managerWithStoredReq :: IO Manager
157+managerWithStoredReq = newManager defaultManagerSettings { managerModifyRequest = go }
158+ where go req = modifyMVar_ currentReq (addReq req) >> return req
159+ addReq req _ = return $ Just (req, "")
src/Servant/QuickCheck/Internal/Testable.hsnew file+96
@@ -0,0 +1,96 @@
1+-- | This module contains QuickCheck-related logic.
2+module Servant.QuickCheck.Internal.Testable where
3+
4+import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
5+import Control.Monad.Except (runExceptT)
6+import GHC.Generics (Generic)
7+import Network.HTTP.Client (Request, RequestBody (..),
8+ requestBody)
9+import Servant.API ((:<|>)(..))
10+import Servant.Client (ServantError (..), ClientM)
11+import System.IO.Unsafe (unsafePerformIO)
12+import Test.QuickCheck (Arbitrary (..), discard)
13+import Test.QuickCheck.Property (Testable (..), forAllShrink,
14+ ioProperty, (.&.))
15+
16+import Servant.QuickCheck.Internal.Predicates
17+
18+
19+-- * ShouldMatch
20+
21+-- | Two corresponding client functions. Used for checking that APIs match.
22+data ShouldMatch a = ShouldMatch a a
23+ deriving (Eq, Show, Read, Generic)
24+
25+instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where
26+ property (ShouldMatch e1 e2) = ioProperty $ do
27+ e1' <- runExceptT e1
28+ e2' <- runExceptT e2
29+ modifyMVar_ currentReq $ \x -> case x of
30+ Nothing -> error "impossible"
31+ Just (x', _) -> return $ Just (x', "LHS:\n" ++ show e1'
32+ ++ "\nRHS:\n" ++ show e2')
33+ case (e1', e2') of
34+ (Right v1, Right v2) -> return $ v1 == v2
35+ (Left (FailureResponse a1 b1 c1), Left (FailureResponse a2 b2 c2)) ->
36+ return $ a1 == a2 && b1 == b2 && c1 == c2
37+ (err1, err2) -> error $ "Exception response:"
38+ ++ "\nLHS:\n" ++ show err1
39+ ++ "\nRHS:\n" ++ show err2
40+
41+instance (Arbitrary a, Show a, Testable (ShouldMatch b))
42+ => Testable (ShouldMatch (a -> b)) where
43+ property (ShouldMatch f1 f2) = forAllShrink arbitrary shrink go
44+ where go x = ShouldMatch (f1 x) (f2 x)
45+
46+instance (Testable (ShouldMatch a), Testable (ShouldMatch b))
47+ => Testable (ShouldMatch (a :<|> b)) where
48+ property (ShouldMatch (a1 :<|> b1) (a2 :<|> b2))
49+ = property (ShouldMatch a1 a2) .&. property (ShouldMatch b1 b2)
50+
51+-- * ShouldSatisfy
52+
53+data ShouldSatisfy filter expect a = ShouldSatisfy
54+ { ssVal :: a
55+ , ssFilter :: Predicates filter
56+ , ssExpect :: Predicates expect
57+ } deriving (Functor)
58+
59+instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
60+ => Testable (ShouldSatisfy filter expect (ClientM a)) where
61+ property (ShouldSatisfy a _ e) = ioProperty $ do
62+ a' <- runExceptT a
63+ modifyMVar_ currentReq $ \x -> case x of
64+ Nothing -> error "impossible"
65+ Just (x', _) -> return $ Just (x', show a')
66+ return $ getPredicate e a'
67+
68+instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
69+ , HasPredicate filter a)
70+ => Testable (ShouldSatisfy filter expect (a -> b)) where
71+ property (ShouldSatisfy g f e) = forAllShrink arbitrary shrink go
72+ where go x | getPredicate f x = ShouldSatisfy (g x) f e
73+ | otherwise = discard
74+
75+instance ( Testable (ShouldSatisfy filter expect a)
76+ , Testable (ShouldSatisfy filter expect b))
77+ => Testable (ShouldSatisfy filter expect (a :<|> b)) where
78+ property (ShouldSatisfy (a :<|> b) f e)
79+ = property (ShouldSatisfy a f e) .&. property (ShouldSatisfy b f e)
80+
81+-- * Utils
82+
83+-- Used to store the current request and response so that in case of failure we
84+-- have the failing test in a user-friendly form.
85+currentReq :: MVar (Maybe (Request, String))
86+currentReq = unsafePerformIO $ newMVar Nothing
87+{-# NOINLINE currentReq #-}
88+
89+prettyErr :: IO String
90+prettyErr = do
91+ Just (req, resp) <- readMVar currentReq
92+ return $ show req ++ "Body:\n" ++ showReqBody (requestBody req)
93+ ++ "\n\nResponse:\n" ++ resp
94+ where
95+ showReqBody (RequestBodyLBS x) = show x
96+ showReqBody _ = error "expecting RequestBodyLBS"
stack.yamlnew file+36
@@ -0,0 +1,36 @@
1+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
2+resolver: nightly-2016-04-20
3+
4+# Local packages, usually specified by relative directory name
5+packages:
6+- '.'
7+- 'doc'
8+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
9+extra-deps:
10+- servant-0.7
11+- servant-client-0.7
12+- servant-server-0.7
13+
14+# Override default flag values for local packages and extra-deps
15+flags: {}
16+
17+# Extra package databases containing global packages
18+extra-package-dbs: []
19+
20+# Control whether we use the GHC we find on the path
21+# system-ghc: true
22+
23+# Require a specific version of stack, using version ranges
24+# require-stack-version: -any # Default
25+# require-stack-version: >= 1.0.0
26+
27+# Override the architecture used by stack, especially useful on Windows
28+# arch: i386
29+# arch: x86_64
30+
31+# Extra directories used by stack for building
32+# extra-include-dirs: [/path/to/dir]
33+# extra-lib-dirs: [/path/to/dir]
34+
35+# Allow a newer minor version of GHC than the snapshot specifies
36+# compiler-check: newer-minor
test/Doctest.hsnew file+44
@@ -0,0 +1,44 @@
1+module Main where
2+
3+import Data.List (isPrefixOf)
4+import System.Directory
5+import System.FilePath
6+import System.FilePath.Find
7+import Test.DocTest
8+
9+main :: IO ()
10+main = do
11+ files <- find always (extension ==? ".hs") "src"
12+ mCabalMacrosFile <- getCabalMacrosFile
13+ doctest $ "-isrc" : "-Iinclude" :
14+ (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++
15+ "-XOverloadedStrings" :
16+ "-XDeriveFunctor" :
17+ "-XFlexibleInstances" :
18+ "-XFlexibleContexts" :
19+ "-XMultiParamTypeClasses" :
20+ "-XDataKinds" :
21+ "-XTypeOperators" :
22+ "-XGADTs" :
23+ files
24+
25+getCabalMacrosFile :: IO (Maybe FilePath)
26+getCabalMacrosFile = do
27+ exists <- doesDirectoryExist "dist"
28+ if exists
29+ then do
30+ contents <- getDirectoryContents "dist"
31+ let rest = "build" </> "autogen" </> "cabal_macros.h"
32+ whenExists $ case filter ("dist-sandbox-" `isPrefixOf`) contents of
33+ [x] -> "dist" </> x </> rest
34+ [] -> "dist" </> rest
35+ xs -> error $ "ran doctests with multiple dist/dist-sandbox-xxxxx's: \n"
36+ ++ show xs ++ "\nTry cabal clean"
37+ else return Nothing
38+ where
39+ whenExists :: FilePath -> IO (Maybe FilePath)
40+ whenExists file = do
41+ exists <- doesFileExist file
42+ return $ if exists
43+ then Just file
44+ else Nothing
test/Servant/CoMock/InternalSpec.hsnew file+170
@@ -0,0 +1,170 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+module Servant.CoMock.InternalSpec (spec) where
4+
5+import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
6+import Control.Monad.IO.Class (liftIO)
7+import Data.Proxy
8+import Servant
9+import Test.Hspec
10+
11+import Servant.CoMock.Internal
12+
13+spec :: Spec
14+spec = do
15+ serversEqualSpec
16+ serverSatisfiesSpec
17+ serverBenchmarkSpec
18+
19+
20+serversEqualSpec :: Spec
21+serversEqualSpec = describe "serversEqual" $ do
22+
23+ context "servers without function types" $ do
24+
25+ it "considers equal servers equal" $ do
26+ withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
27+ serversEqual onlyReturnAPI burl burl noOfTestCases
28+
29+ it "considers unequal servers unequal" $ do
30+ withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl1 ->
31+ withServantServer onlyReturnAPI onlyReturnAPIServer' $ \burl2 ->
32+ serversUnequal onlyReturnAPI burl1 burl2 noOfTestCases
33+
34+
35+ context "servers with function types" $ do
36+
37+ it "considers equal servers equal" $ do
38+ withServantServer functionAPI functionAPIServer $ \burl ->
39+ serversEqual functionAPI burl burl noOfTestCases
40+
41+ it "considers unequal servers unequal" $ do
42+ withServantServer functionAPI functionAPIServer $ \burl1 ->
43+ withServantServer functionAPI functionAPIServer' $ \burl2 ->
44+ serversUnequal functionAPI burl1 burl2 noOfTestCases
45+
46+
47+ context "stateful servers" $ do
48+
49+ it "considers equal servers equal" $ do
50+ withServantServer statefulAPI statefulAPIServer $ \burl1 ->
51+ withServantServer statefulAPI statefulAPIServer $ \burl2 ->
52+ serversEqual statefulAPI burl1 burl2 noOfTestCases
53+
54+
55+serverSatisfiesSpec :: Spec
56+serverSatisfiesSpec = describe "serverSatisfies" $ do
57+
58+ it "passes true predicates" $ do
59+ let e = addRightPredicate (== (5 :: Int)) emptyPredicates
60+ withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
61+ serverSatisfies onlyReturnAPI burl emptyPredicates e noOfTestCases
62+
63+ it "fails false predicates" $ do
64+ let e = addRightPredicate (== (4 :: Int)) emptyPredicates
65+ withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
66+ serverDoesntSatisfy onlyReturnAPI burl emptyPredicates e noOfTestCases
67+
68+ it "allows filtering" $ do
69+ let f = addPredicate (\(x :: String) -> length x > 2) emptyPredicates
70+ e = addRightPredicate (\(x :: Int) -> x > 2) emptyPredicates
71+ e' = addRightPredicate (\(x :: Int) -> x < 2) emptyPredicates
72+ withServantServer functionAPI functionAPIServer $ \burl -> do
73+ serverSatisfies functionAPI burl f e noOfTestCases
74+ serverDoesntSatisfy functionAPI burl f e' noOfTestCases
75+
76+ it "allows polymorphic predicates" $ do
77+ let p1 x = length (show x) < 100000
78+ p2 x = length (show x) < 1
79+ e1 = addPolyPredicate (Proxy :: Proxy Show) p1 emptyPredicates
80+ e2 = addPolyPredicate (Proxy :: Proxy Show) p2 emptyPredicates
81+ withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl -> do
82+ serverSatisfies onlyReturnAPI burl emptyPredicates e1 noOfTestCases
83+ serverDoesntSatisfy onlyReturnAPI burl emptyPredicates e2 noOfTestCases
84+
85+
86+ context "never500s" $ do
87+
88+ it "is true for servers that don't return 500s" $ do
89+ withServantServer functionAPI functionAPIServer $ \burl ->
90+ serverSatisfies functionAPI burl emptyPredicates never500s noOfTestCases
91+
92+ it "is false for servers that return 500s" $ do
93+ withServantServer onlyReturnAPI onlyReturnAPIServer'' $ \burl ->
94+ serverDoesntSatisfy onlyReturnAPI burl emptyPredicates never500s noOfTestCases
95+
96+ context "onlyJsonObjects" $ do
97+
98+ it "is false for servers that return top-level literals" $ do
99+ withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
100+ serverDoesntSatisfy onlyReturnAPI burl emptyPredicates onlyJsonObjects noOfTestCases
101+
102+
103+serverBenchmarkSpec :: Spec
104+serverBenchmarkSpec = describe "serverBenchmark" $ do
105+
106+ it "works" $ do
107+ withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
108+ serverBenchmark onlyReturnAPI burl defaultBenchOptions
109+
110+------------------------------------------------------------------------------
111+-- APIs
112+------------------------------------------------------------------------------
113+
114+-- * OnlyReturn
115+
116+type OnlyReturnAPI = Get '[JSON] Int
117+ :<|> Post '[JSON] String
118+
119+onlyReturnAPI :: Proxy OnlyReturnAPI
120+onlyReturnAPI = Proxy
121+
122+onlyReturnAPIServer :: IO (Server OnlyReturnAPI)
123+onlyReturnAPIServer = return $ return 5 :<|> return "hi"
124+
125+onlyReturnAPIServer' :: IO (Server OnlyReturnAPI)
126+onlyReturnAPIServer' = return $ return 5 :<|> return "hia"
127+
128+onlyReturnAPIServer'' :: IO (Server OnlyReturnAPI)
129+onlyReturnAPIServer'' = return $ error "err" :<|> return "hia"
130+
131+-- * Function
132+
133+type FunctionAPI = ReqBody '[JSON] String :> Post '[JSON] Int
134+ :<|> Header "X-abool" Bool :> Get '[JSON] (Maybe Bool)
135+
136+functionAPI :: Proxy FunctionAPI
137+functionAPI = Proxy
138+
139+functionAPIServer :: IO (Server FunctionAPI)
140+functionAPIServer = return $ return . length :<|> return
141+
142+functionAPIServer' :: IO (Server FunctionAPI)
143+functionAPIServer'
144+ = return $ (\x -> return $ length x - 1) :<|> \x -> return (not <$> x)
145+
146+-- * Stateful
147+
148+type StatefulAPI = ReqBody '[JSON] String :> Post '[JSON] String
149+ :<|> Get '[JSON] Int
150+
151+statefulAPI :: Proxy StatefulAPI
152+statefulAPI = Proxy
153+
154+statefulAPIServer :: IO (Server StatefulAPI)
155+statefulAPIServer = do
156+ mvar <- newMVar ""
157+ return $ (\x -> liftIO $ swapMVar mvar x)
158+ :<|> (liftIO $ readMVar mvar >>= return . length)
159+
160+
161+------------------------------------------------------------------------------
162+-- Utils
163+------------------------------------------------------------------------------
164+
165+noOfTestCases :: Int
166+#if LONG_TESTS
167+noOfTestCases = 20000
168+#else
169+noOfTestCases = 500
170+#endif
test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}