ilyakooo0/servant-quickcheck
1
0
Fork 0
mirror of https://github.com/ilyakooo0/servant-quickcheck.git synced 2024-11-22 05:42:11 +03:00
Code Issues Packages Projects Releases Wiki Activity

initial commit

Browse Source
This commit is contained in:
Julian K. Arni 2016-04-22 13:00:23 +02:00
commit 72abea9b0f
23 changed files with 1752 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored Normal file
View File

@ -0,0 +1 @@
doc/_build/

34
.travis.yml Normal file
View File

@ -0,0 +1,34 @@
sudo: false
language: c
env:
- GHCVER=7.8.4
- GHCVER=7.10.2
addons:
apt:
sources:
- hvr-ghc
packages:
- ghc-7.8.4
- ghc-7.10.2
- cabal-install-1.22
- libgmp-dev
- wrk
install:
- (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH
- ghc --version
- cabal --version
- travis_retry cabal update
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
script:
- tinc && cabal configure --enable-tests && cabal build && cabal test
- (cd doc && tinc cabal configure --enable-tests && cabal build && cabal test)
cache:
directories:
- $HOME/.tinc/cache

30
LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright (c) 2016, Julian K. Arni
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Julian K. Arni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

2
Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

30
doc/LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright (c) 2016, Julian K. Arni
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Julian K. Arni nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

216
doc/Makefile Normal file
View File

@ -0,0 +1,216 @@
# Makefile for Sphinx documentation
#
# You can set these variables from the command line.
SPHINXOPTS =
SPHINXBUILD = sphinx-build
PAPER =
BUILDDIR = _build
# User-friendly check for sphinx-build
ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1)
$(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/)
endif
# Internal variables.
PAPEROPT_a4 = -D latex_paper_size=a4
PAPEROPT_letter = -D latex_paper_size=letter
ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
# the i18n builder cannot share the environment and doctrees with the others
I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) .
.PHONY: help
help:
@echo "Please use \`make <target>' where <target> is one of"
@echo " html to make standalone HTML files"
@echo " dirhtml to make HTML files named index.html in directories"
@echo " singlehtml to make a single large HTML file"
@echo " pickle to make pickle files"
@echo " json to make JSON files"
@echo " htmlhelp to make HTML files and a HTML help project"
@echo " qthelp to make HTML files and a qthelp project"
@echo " applehelp to make an Apple Help Book"
@echo " devhelp to make HTML files and a Devhelp project"
@echo " epub to make an epub"
@echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter"
@echo " latexpdf to make LaTeX files and run them through pdflatex"
@echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx"
@echo " text to make text files"
@echo " man to make manual pages"
@echo " texinfo to make Texinfo files"
@echo " info to make Texinfo files and run them through makeinfo"
@echo " gettext to make PO message catalogs"
@echo " changes to make an overview of all changed/added/deprecated items"
@echo " xml to make Docutils-native XML files"
@echo " pseudoxml to make pseudoxml-XML files for display purposes"
@echo " linkcheck to check all external links for integrity"
@echo " doctest to run all doctests embedded in the documentation (if enabled)"
@echo " coverage to run coverage check of the documentation (if enabled)"
.PHONY: clean
clean:
rm -rf $(BUILDDIR)/*
.PHONY: html
html:
$(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html
@echo
@echo "Build finished. The HTML pages are in $(BUILDDIR)/html."
.PHONY: dirhtml
dirhtml:
$(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml
@echo
@echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml."
.PHONY: singlehtml
singlehtml:
$(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml
@echo
@echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml."
.PHONY: pickle
pickle:
$(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle
@echo
@echo "Build finished; now you can process the pickle files."
.PHONY: json
json:
$(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json
@echo
@echo "Build finished; now you can process the JSON files."
.PHONY: htmlhelp
htmlhelp:
$(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp
@echo
@echo "Build finished; now you can run HTML Help Workshop with the" \
".hhp project file in $(BUILDDIR)/htmlhelp."
.PHONY: qthelp
qthelp:
$(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp
@echo
@echo "Build finished; now you can run "qcollectiongenerator" with the" \
".qhcp project file in $(BUILDDIR)/qthelp, like this:"
@echo "# qcollectiongenerator $(BUILDDIR)/qthelp/generics-eot.qhcp"
@echo "To view the help file:"
@echo "# assistant -collectionFile $(BUILDDIR)/qthelp/generics-eot.qhc"
.PHONY: applehelp
applehelp:
$(SPHINXBUILD) -b applehelp $(ALLSPHINXOPTS) $(BUILDDIR)/applehelp
@echo
@echo "Build finished. The help book is in $(BUILDDIR)/applehelp."
@echo "N.B. You won't be able to view it unless you put it in" \
"~/Library/Documentation/Help or install it in your application" \
"bundle."
.PHONY: devhelp
devhelp:
$(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp
@echo
@echo "Build finished."
@echo "To view the help file:"
@echo "# mkdir -p $$HOME/.local/share/devhelp/generics-eot"
@echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/generics-eot"
@echo "# devhelp"
.PHONY: epub
epub:
$(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub
@echo
@echo "Build finished. The epub file is in $(BUILDDIR)/epub."
.PHONY: latex
latex:
$(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
@echo
@echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex."
@echo "Run \`make' in that directory to run these through (pdf)latex" \
"(use \`make latexpdf' here to do that automatically)."
.PHONY: latexpdf
latexpdf:
$(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
@echo "Running LaTeX files through pdflatex..."
$(MAKE) -C $(BUILDDIR)/latex all-pdf
@echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
.PHONY: latexpdfja
latexpdfja:
$(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex
@echo "Running LaTeX files through platex and dvipdfmx..."
$(MAKE) -C $(BUILDDIR)/latex all-pdf-ja
@echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex."
.PHONY: text
text:
$(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text
@echo
@echo "Build finished. The text files are in $(BUILDDIR)/text."
.PHONY: man
man:
$(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man
@echo
@echo "Build finished. The manual pages are in $(BUILDDIR)/man."
.PHONY: texinfo
texinfo:
$(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
@echo
@echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo."
@echo "Run \`make' in that directory to run these through makeinfo" \
"(use \`make info' here to do that automatically)."
.PHONY: info
info:
$(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo
@echo "Running Texinfo files through makeinfo..."
make -C $(BUILDDIR)/texinfo info
@echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo."
.PHONY: gettext
gettext:
$(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale
@echo
@echo "Build finished. The message catalogs are in $(BUILDDIR)/locale."
.PHONY: changes
changes:
$(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes
@echo
@echo "The overview file is in $(BUILDDIR)/changes."
.PHONY: linkcheck
linkcheck:
$(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck
@echo
@echo "Link check complete; look for any errors in the above output " \
"or in $(BUILDDIR)/linkcheck/output.txt."
.PHONY: doctest
doctest:
$(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest
@echo "Testing of doctests in the sources finished, look at the " \
"results in $(BUILDDIR)/doctest/output.txt."
.PHONY: coverage
coverage:
$(SPHINXBUILD) -b coverage $(ALLSPHINXOPTS) $(BUILDDIR)/coverage
@echo "Testing of coverage in the sources finished, look at the " \
"results in $(BUILDDIR)/coverage/python.txt."
.PHONY: xml
xml:
$(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml
@echo
@echo "Build finished. The XML files are in $(BUILDDIR)/xml."
.PHONY: pseudoxml
pseudoxml:
$(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml
@echo
@echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml."

166
doc/ServersEqual.lhs Normal file
View File

@ -0,0 +1,166 @@
# Testing that servers behave identically
## Rewriting an application
If you are rewriting, or significantly refactoring, an application, you often
want to ensure that the behaviour of the rewritten application is the same as
that of the old one. Sometimes what the behaviour of the old application is is
not always clear, making the process a difficult and error-prone one.
**servant-quickcheck** can help. It provides a `serversEqual` function that,
given a **servant** API type and two URLs, generates arbitrary requests of the
right type and checks that, for the same request *history*, the two servers
respond identically.
To see how this works, let's re-implement the [Django
Todo-Backend](https://github.com/mihirk/todo-backend-django) application
in **servant**. (`serversEqual` works for non-**servant** applications, though
it's somewhat nicer to use when one of them is written with **servant**.) You
don't need to know anything about Django or Python to follow along; indeed,
part of the fun of it is using `serversEqual` to guide you through
re-implementing code you may not entirely understand.
Looking at the code, we can see the routes in `urls.py`:
``` python
urlpatterns = patterns('',
url(r'^$', RedirectView.as_view(url='/todos')),
url(r'^todos$', views.TodoList.as_view()),
url(r'^todo/(?P<pk>[0-9]+)$', views.Todo.as_view()),
)
```
And the handlers in `views.py`:
``` python
class TodoList(APIView):
def get(self, request, format=None):
todo_items = TodoItem.objects.all()
serializer = TodoItemSerializer(todo_items, many=True)
return JSONResponse(serializer.data, status=status.HTTP_200_OK)
def post(self, request, format=None):
serializer = TodoItemSerializer(data=request.DATA)
if serializer.is_valid():
saved_item = serializer.save()
saved_item.url = request.build_absolute_uri('/todo/' + str(saved_item.id))
saved_item.save()
serializer = TodoItemSerializer(instance=saved_item)
return JSONResponse(serializer.data, status=status.HTTP_201_CREATED)
return JSONResponse(serializer.errors, status=status.HTTP_400_BAD_REQUEST)
def delete(self, request, format=None):
TodoItem.objects.all().delete()
return JSONResponse(None, status=status.HTTP_204_NO_CONTENT)
class Todo(APIView):
def get(self, request, pk, format=None):
try:
todoItem = TodoItem.objects.get(pk=pk)
serializer = TodoItemSerializer(todoItem)
except TodoItem.DoesNotExist:
return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
return JSONResponse(serializer.data, status=status.HTTP_200_OK)
def delete(self, request, pk, format=None):
try:
todoItem = TodoItem.objects.get(pk=pk)
todoItem.delete()
except TodoItem.DoesNotExist:
return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
return JSONResponse(None, status=status.HTTP_204_NO_CONTENT)
def patch(self, request, pk, format=None):
try:
todoItem = TodoItem.objects.get(pk=pk)
except TodoItem.DoesNotExist:
return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
serializer = TodoItemSerializer(data=request.DATA, instance=todoItem, partial=True)
if serializer.is_valid():
serializer.save()
return JSONResponse(serializer.data, status=status.HTTP_200_OK)
return JSONResponse(serializer.errors, status=status.HTTP_400_BAD_REQUEST)
```
And from `models.py`:
``` python
class TodoItem(models.Model):
title = models.CharField(max_length=256, null=True, blank=True)
completed = models.NullBooleanField(null=True, blank=True, default=False)
url = models.CharField(max_length=256, null=True, blank=True)
order = models.IntegerField(null=True, blank=True)
```
So as a first pass, let's try:
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
import Servant
import Servant.QuickCheck
import STMContainers.Map as M
import GHC.Conc (atomically)
import Test.QuickCheck
data Todo = Todo
{ title :: String
, completed :: Bool
, url :: String
, order :: Int
} deriving (Eq, Show, Read)
type API = TodosAPI :<|> TodoAPI
type TodosAPI
= "todos" :>
( Get '[JSON] [Todo]
:<|> ReqBody '[JSON] Todo :> Post '[JSON] ()
:<|> Delete '[JSON] ())
type TodoAPI
= "todo" :> Capture "id " Int :>
( Get '[JSON] Todo
:<|> ReqBody '[JSON] Todo :> Patch '[JSON] ()
:<|> Delete '[JSON} ())
serverTodos :: Server TodosAPI
serverTodos tvar = getTodos tvar
:<|> postTodos tvar
:<|> deleteAllTodos tvar
serverTodo :: Server TodoAPI
serverTodo id' = getTodo tvar id'
:<|> patchTodo tvar id'
:<|> deleteTodo tvar id'
getTodos :: Map Int Todo -> Handler [Todo]
getTodos m = liftIO . atomically . toList $ S.stream m
postTodos :: Map Int Todo -> Todo -> Handler ()
postTodos m t = liftIO . atomically $ S.insert m t
deleteTodos :: Map Int Todo -> Todo -> Handler ()
deleteTodos m t = liftIO . atomically $ S.insert m t
```
(We're keeping the `Todo`s in memory for simplicity - if this were a production
application, we'd likely want to use a database.)
Notice that we split up the API into two sub-APIs. Partly this makes things
cleaner and more readable, but there's also a more concrete benefit: we can
start testing that **parts** of the API have been correctly rewritten without
implementing the entire server.
In order to check how we're doing, we need to add an `Arbitrary` instance for
`Todo`:
``` haskell
instance Arbitrary Todo where
arbitrary = Todo <$> arbitrary <$> arbitrary <$> arbitrary <$> arbitrary
```

2
doc/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

294
doc/conf.py Normal file
View File

@ -0,0 +1,294 @@
# -*- coding: utf-8 -*-
#
# servant documentation build configuration file, created by
# sphinx-quickstart on Mon Nov 23 13:24:36 2015.
#
# This file is execfile()d with the current directory set to its
# containing dir.
#
# Note that not all possible configuration values are present in this
# autogenerated file.
#
# All configuration values have a default; values that are commented out
# serve to show the default.
import sys
import os
import shlex
from recommonmark.parser import CommonMarkParser
# If extensions (or modules to document with autodoc) are in another directory,
# add these directories to sys.path here. If the directory is relative to the
# documentation root, use os.path.abspath to make it absolute, like shown here.
#sys.path.insert(0, os.path.abspath('.'))
# -- General configuration ------------------------------------------------
# If your documentation needs a minimal Sphinx version, state it here.
#needs_sphinx = '1.0'
# Add any Sphinx extension module names here, as strings. They can be
# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
# ones.
extensions = []
# Add any paths that contain templates here, relative to this directory.
templates_path = ['_templates']
# The suffix(es) of source filenames.
# You can specify multiple suffix as a list of string:
source_suffix = ['.md', '.rst', '.lhs']
# The encoding of source files.
#source_encoding = 'utf-8-sig'
# The master toctree document.
master_doc = 'index'
# General information about the project.
project = u'servant-quickcheck'
copyright = u'2016, Servant Contributors'
author = u'Servant Contributors'
# The version info for the project you're documenting, acts as replacement for
# |version| and |release|, also used in various other places throughout the
# built documents.
#
# The short X.Y version.
# version = 'latest'
# The full version, including alpha/beta/rc tags.
# release = 'latest'
# The language for content autogenerated by Sphinx. Refer to documentation
# for a list of supported languages.
#
# This is also used if you do content translation via gettext catalogs.
# Usually you set "language" from the command line for these cases.
language = None
# There are two options for replacing |today|: either, you set today to some
# non-false value, then it is used:
#today = ''
# Else, today_fmt is used as the format for a strftime call.
#today_fmt = '%B %d, %Y'
# List of patterns, relative to source directory, that match files and
# directories to ignore when looking for source files.
exclude_patterns = ['_build', 'venv']
# The reST default role (used for this markup: `text`) to use for all
# documents.
#default_role = None
# If true, '()' will be appended to :func: etc. cross-reference text.
#add_function_parentheses = True
# If true, the current module name will be prepended to all description
# unit titles (such as .. function::).
#add_module_names = True
# If true, sectionauthor and moduleauthor directives will be shown in the
# output. They are ignored by default.
#show_authors = False
# The name of the Pygments (syntax highlighting) style to use.
pygments_style = 'sphinx'
def setup(app):
from sphinx.highlighting import lexers
from pygments.lexers import HaskellLexer
lexers['haskell ignore'] = HaskellLexer(stripnl=False)
# A list of ignored prefixes for module index sorting.
#modindex_common_prefix = []
# If true, keep warnings as "system message" paragraphs in the built documents.
#keep_warnings = False
# If true, `todo` and `todoList` produce output, else they produce nothing.
todo_include_todos = False
# -- Options for HTML output ----------------------------------------------
# The theme to use for HTML and HTML Help pages. See the documentation for
# a list of builtin themes.
html_theme = 'sphinx_rtd_theme'
# Theme options are theme-specific and customize the look and feel of a theme
# further. For a list of options available for each theme, see the
# documentation.
#html_theme_options = {}
# Add any paths that contain custom themes here, relative to this directory.
#html_theme_path = []
# The name for this set of Sphinx documents. If None, it defaults to
# "<project> v<release> documentation".
#html_title = None
# A shorter title for the navigation bar. Default is the same as html_title.
#html_short_title = None
# The name of an image file (relative to this directory) to place at the top
# of the sidebar.
#html_logo = None
# The name of an image file (within the static path) to use as favicon of the
# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
# pixels large.
#html_favicon = None
# Add any paths that contain custom static files (such as style sheets) here,
# relative to this directory. They are copied after the builtin static files,
# so a file named "default.css" will overwrite the builtin "default.css".
html_static_path = ['_static']
# Add any extra paths that contain custom files (such as robots.txt or
# .htaccess) here, relative to this directory. These files are copied
# directly to the root of the documentation.
#html_extra_path = []
# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
# using the given strftime format.
#html_last_updated_fmt = '%b %d, %Y'
# If true, SmartyPants will be used to convert quotes and dashes to
# typographically correct entities.
#html_use_smartypants = True
# Custom sidebar templates, maps document names to template names.
#html_sidebars = {}
# Additional templates that should be rendered to pages, maps page names to
# template names.
#html_additional_pages = {}
# If false, no module index is generated.
#html_domain_indices = True
# If false, no index is generated.
#html_use_index = True
# If true, the index is split into individual pages for each letter.
#html_split_index = False
# If true, links to the reST sources are added to the pages.
#html_show_sourcelink = True
# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
#html_show_sphinx = True
# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
#html_show_copyright = True
# If true, an OpenSearch description file will be output, and all pages will
# contain a <link> tag referring to it. The value of this option must be the
# base URL from which the finished HTML is served.
#html_use_opensearch = ''
# This is the file name suffix for HTML files (e.g. ".xhtml").
#html_file_suffix = None
# Language to be used for generating the HTML full-text search index.
# Sphinx supports the following languages:
# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja'
# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr'
#html_search_language = 'en'
# A dictionary with options for the search language support, empty by default.
# Now only 'ja' uses this config value
#html_search_options = {'type': 'default'}
# The name of a javascript file (relative to the configuration directory) that
# implements a search results scorer. If empty, the default will be used.
#html_search_scorer = 'scorer.js'
# Output file base name for HTML help builder.
htmlhelp_basename = 'servantdoc'
# -- Options for LaTeX output ---------------------------------------------
latex_elements = {
# The paper size ('letterpaper' or 'a4paper').
#'papersize': 'letterpaper',
# The font size ('10pt', '11pt' or '12pt').
#'pointsize': '10pt',
# Additional stuff for the LaTeX preamble.
#'preamble': '',
# Latex figure (float) alignment
#'figure_align': 'htbp',
}
# Grouping the document tree into LaTeX files. List of tuples
# (source start file, target name, title,
# author, documentclass [howto, manual, or own class]).
latex_documents = [
(master_doc, 'servant-quickcheck.tex', u'servant-quickcheck Documentation',
u'Servant Contributors', 'manual'),
]
# The name of an image file (relative to this directory) to place at the top of
# the title page.
#latex_logo = None
# For "manual" documents, if this is true, then toplevel headings are parts,
# not chapters.
#latex_use_parts = False
# If true, show page references after internal links.
#latex_show_pagerefs = False
# If true, show URL addresses after external links.
#latex_show_urls = False
# Documents to append as an appendix to all manuals.
#latex_appendices = []
# If false, no module index is generated.
#latex_domain_indices = True
# -- Options for manual page output ---------------------------------------
# One entry per manual page. List of tuples
# (source start file, name, description, authors, manual section).
man_pages = [
(master_doc, 'servant-quickcheck', u'servant-quickcheck Documentation',
[author], 1)
]
# If true, show URL addresses after external links.
#man_show_urls = False
# -- Options for Texinfo output -------------------------------------------
# Grouping the document tree into Texinfo files. List of tuples
# (source start file, target name, title, author,
# dir menu entry, description, category)
texinfo_documents = [
(master_doc, 'servant-quickcheck', u'servant-quickcheck Documentation',
author, 'servant-quickcheck', 'One line description of project.',
'Miscellaneous'),
]
# Documents to append as an appendix to all manuals.
#texinfo_appendices = []
# If false, no module index is generated.
#texinfo_domain_indices = True
# How to display URL addresses: 'footnote', 'no', or 'inline'.
#texinfo_show_urls = 'footnote'
# If true, do not generate a @detailmenu in the "Top" node's menu.
#texinfo_no_detailmenu = False
source_parsers = {
'.md': CommonMarkParser,
'.lhs': CommonMarkParser,
}

17
doc/doc.cabal Normal file
View File

@ -0,0 +1,17 @@
name: doc
version: 0.1.0.0
license: BSD3
license-file: LICENSE
author: Julian K. Arni
maintainer: jkarni@gmail.com
build-type: Simple
cabal-version: >=1.10
library
exposed-modules: ServersEqual
other-extensions: DataKinds, TypeOperators
build-depends: base >=4.8 && <4.9
, servant-server == 0.7.*
ghc-options: -Wall -Werror -pgmL markdown-unlit
default-language: Haskell2010

22
doc/index.rst Normal file
View File

@ -0,0 +1,22 @@
servant-quickcheck – QuickCheck entire APIs
============================================
**servant-quickcheck** provides ways of observing and testing the behaviour of
webservers under arbitrary, but sensible, requests. ('Sensible' here means
requests which have the correct type for their arguments (captures, query
params, headers, and request bodies).)
**servant-quickcheck** can currently:
- Test whether two servers behave identically when provided the same inputs
in the same order;
- Test whether certain properties hold true of an entire API (e.g. that an
API never throws a 500 error);
- Stress test arbitrary endpoints in an API.
.. toctree::
:maxdepth: 1
ServersEqual.lhs
ServerSatisfies.lhs
ServerBenchmark.lhs

25
doc/requirements.txt Normal file
View File

@ -0,0 +1,25 @@
alabaster==0.7.7
argh==0.26.1
Babel==2.2.0
backports-abc==0.4
backports.ssl-match-hostname==3.5.0.1
certifi==2015.11.20.1
CommonMark==0.5.4
docutils==0.12
Jinja2==2.8
livereload==2.4.1
MarkupSafe==0.23
pathtools==0.1.2
Pygments==2.1.1
pytz==2015.7
PyYAML==3.11
recommonmark==0.4.0
singledispatch==3.4.0.3
six==1.10.0
snowballstemmer==1.2.1
Sphinx==1.3.4
sphinx-autobuild==0.5.2
sphinx-rtd-theme==0.1.9
tornado==4.3
watchdog==0.8.3
wheel==0.26.0

88
servant-quickcheck.cabal Normal file
View File

@ -0,0 +1,88 @@
name: servant-quickcheck
version: 0.1.0.0
synopsis: QuickCheck entire APIs
description:
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
flag long-tests
description: Run more QuickCheck tests
default: False
library
exposed-modules: Servant.QuickCheck
, Servant.QuickCheck.Internal
, Servant.QuickCheck.Internal.Benchmarking
, Servant.QuickCheck.Internal.Predicates
, Servant.QuickCheck.Internal.Testable
, Servant.QuickCheck.Internal.QuickCheck
build-depends: base >=4.8 && <4.9
, QuickCheck == 2.8.*
, bytestring == 0.10.*
, aeson > 0.10 && < 0.12
, mtl == 2.2.*
, http-client == 0.4.*
, http-types == 0.9.*
, servant-client == 0.7.*
, servant-server == 0.7.*
, servant == 0.7.*
, warp >= 3.2.4 && < 3.3
, process == 1.2.*
, temporary == 1.2.*
, hspec
hs-source-dirs: src
default-extensions: TypeOperators
, FlexibleInstances
, FlexibleContexts
, DataKinds
, GADTs
, MultiParamTypeClasses
, DeriveFunctor
, RankNTypes
, ConstraintKinds
, DeriveGeneric
default-language: Haskell2010
test-suite spec
type: exitcode-stdio-1.0
ghc-options: -Wall -O2 -threaded
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
other-modules: Servant.QuickCheck.InternalSpec
build-depends: base == 4.*
, servant-quickcheck
, hspec
, http-client
, warp
, servant-server
, servant-client
, transformers
, QuickCheck
default-extensions: TypeOperators
, FlexibleInstances
, FlexibleContexts
, DataKinds
if flag(long-tests)
cpp-options: -DLONG_TESTS
-- test-suite doctests
-- default-language: Haskell2010
-- type: exitcode-stdio-1.0
-- ghc-options: -threaded
-- main-is: Doctest.hs
-- hs-source-dirs: test
-- build-depends: base >4 && <5
-- , doctest
-- , filemanip
-- , directory
-- , filepath
-- HS-Source-Dirs: test

94
src/Servant/QuickCheck.hs Normal file
View File

@ -0,0 +1,94 @@
-- | @Servant.QuickCheck@ provides utilities related to using QuickCheck over an API.
-- Rather than specifying properties that individual handlers must satisfy,
-- you can state properties that ought to hold true of the entire API.
--
-- While the API must be described with @servant@ types, the server being
-- tested itself need not be implemented with @servant-server@ (or indeed,
-- written in Haskell).
--
-- /N.B./ The examples given here assume the following setup:
--
-- > import Servant
-- > import Servant.QuickCheck
-- > import Test.Hspec
-- >
-- > type API = ReqBody '[JSON] Int :> Post '[JSON] String
-- >
-- > api :: Proxy API
-- > api = Proxy
module Servant.QuickCheck
(
-- * Server properties
-- | Functions to verify that a server meets certain properties.
--
-- Example:
--
-- > server :: Server API
-- > server = return . show
-- >
-- >
-- > test :: Spec
-- > test = describe "my server" $ do
-- >
-- > it "never throws a 500 on valid input" $ do
-- > withServantServer api server $ \url ->
-- > serverSatisfiers api url emptyPredicates never500s 100
serverSatisfies
-- * Server equality
-- | Functions to verify that two servers behave identically.
--
-- This can be useful when for example rewriting or refactoring an
-- application.
--
-- Example:
--
-- > server :: Server API
-- > server = return . show
-- >
-- > server2 :: Server API
-- > server2 = const $ return "hi"
-- >
-- > test :: Spec
-- > test = describe "my new server" $ do
-- >
-- > it "behaves like the old one" $ do
-- > withServantServer api server $ \url1 ->
-- > withServantServer api server2 $ \url2 ->
-- > serversEqual api url1 url2 100
--
, serversEqual
-- * Server benchmarking
-- | Functions that randomly generate and run benchmarking scripts
, serverBenchmark
, BenchOptions(..)
, defaultBenchOptions
-- * Test setup helpers
-- | Helpers to setup and teardown @servant@ servers during tests.
, withServantServer
-- * Predicates
-- | Predicates (functions with signatures @a -> Bool@) are used to filter
-- out QuickCheck-generated values (so as to specify that requests must
-- possess certain properties) and to check that the response specifies the
-- expected properties.
, Predicates
, emptyPredicates
, addPredicate
, addPolyPredicate
-- ** Predicate convenience functions
, addRightPredicate
, addLeftPredicate
-- ** Useful predicates
, never500s
, onlyJsonObjects
) where
import Servant.QuickCheck.Internal

6
src/Servant/QuickCheck/Internal.hs Normal file
View File

@ -0,0 +1,6 @@
module Servant.QuickCheck.Internal (module X) where
import Servant.QuickCheck.Internal.Testable as X
import Servant.QuickCheck.Internal.Predicates as X
import Servant.QuickCheck.Internal.QuickCheck as X
import Servant.QuickCheck.Internal.Benchmarking as X

87
src/Servant/QuickCheck/Internal/Benchmarking.hs Normal file
View File

@ -0,0 +1,87 @@
-- | This module contains benchmark-related logic.
--
-- Currently it generates 'wrk' scripts rather than benchmarking directly with
-- the @servant-client@ functions since the performance of 'wrk' is
-- significantly better.
module Servant.QuickCheck.Internal.Benchmarking where
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (toStrict)
import Network.HTTP.Client
import Network.HTTP.Types
import Servant.Client
data BenchOptions = BenchOptions
{ duration :: Int
, threads :: Int
, connections :: Int
, noOfTests :: Int
} deriving (Eq, Show, Read)
defaultBenchOptions :: BenchOptions
defaultBenchOptions = BenchOptions
{ duration = 10
, threads = 1
, connections = 10
, noOfTests = 10
}
data WrkScript = WrkScript
{ wrkScheme :: Scheme
, wrkHost :: ByteString
, wrkPort :: Int
, wrkMethod :: Method
, wrkPath :: ByteString
, wrkHeaders :: [Header]
, wrkBody :: ByteString
} deriving (Eq, Show)
mkScript :: WrkScript -> String
mkScript w
= "wrk.scheme = \"" ++ sscheme (wrkScheme w) ++ "\""
++ "\nwrk.host = " ++ show (wrkHost w)
++ "\nwrk.port = " ++ show (wrkPort w)
++ "\nwrk.method = " ++ show (wrkMethod w)
++ "\nwrk.path = " ++ show (wrkPath w)
++ foldr (\(h,v) old -> old ++ "\nwrk.headers[" ++ show h ++ "] = " ++ show v)
""
(wrkHeaders w)
++ "\nwrk.body = " ++ show (wrkBody w)
++ "\n" ++ reportFmt
where
sscheme Http = "http"
sscheme Https = "https"
reqToWrk :: Request -> WrkScript
reqToWrk r = WrkScript
{ wrkScheme = Http
, wrkHost = host r
, wrkPort = port r
, wrkMethod = method r
, wrkPath = path r
, wrkHeaders = requestHeaders r
, wrkBody = case requestBody r of
RequestBodyLBS r' -> toStrict r'
_ -> error "expecting RequestBodyLBS"
}
reportFmt :: String
reportFmt
= "done = function(summary, latency, requests)\n"
++ " for _, p in pairs({ 50, 75, 99, 99.999 }) do\n"
++ " n = latency:percentile(p)\n"
++ " io.write(string.format(\"%g%%, %d\\n\", p, n))\n"
++ " end\n"
++ "end\n"
{-data BenchResult = BenchResult-}
{-{ benchReq :: Request-}
{-, benchLatencyDist :: [(Percentile, Microsecs)]-}
{-, benchLatencyAvg :: Microsecs-}
{-} deriving (Eq, Show, Read, Generic)-}
{-newtype Microsecs = Microsecs { unMicroSecs :: Int }-}
{-deriving (Eq, Show, Read, Generic)-}
{-newtype Percentile = Percentile { unPercentile :: Int }-}
{-deriving (Eq, Show, Read, Generic)-}

132
src/Servant/QuickCheck/Internal/Predicates.hs Normal file
View File

@ -0,0 +1,132 @@
-- | This module contains all logic related to constructing or using
-- @Predicates@.
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.QuickCheck.Internal.Predicates where
import Data.Aeson (ToJSON (toJSON), Value (..))
import Data.Proxy (Proxy (..))
import Data.Void
import Network.HTTP.Types (statusCode)
import Servant.Common.Req (ServantError (..))
import Test.QuickCheck
-- | An HList containing predicates (functions of type @a -> Bool@). This
-- datatype is used to represent both filters (what values to discard when
-- generating arguments to test an API) and tests results (what to consider a
-- failing response).
--
-- For both filters and test results, only the *first* predicate of the
-- appropriate type is used.
--
-- Use 'emptyPredicates', 'addPredicate', 'addLeftPredicate' and
-- 'addRightPredicate' to construct a @Predicates@.
data Predicates a where
HNil :: Predicates '[]
HCons :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
HConsC :: Constraint a -> Predicates b -> Predicates (Constraint a ': b)
class HasPredicate a b where
getPredicate :: Predicates a -> b -> Bool
instance {-# OVERLAPPING #-} HasPredicate '[] a where
getPredicate _ = const True
-- TODO: Find some better way of distinguishing how the predicate is being used
instance {-# OVERLAPPING #-} HasPredicate '[] (Either ServantError a) where
getPredicate _ = discard
instance {-# OVERLAPPING #-} HasPredicate (a ': xs) a where
getPredicate (HCons a _) = a
getPredicate (HConsC _ _) = error "not impossible, but non-sensical"
data Constraint ctx = Constraint
{ getConstraint :: forall a . (ctx a) => a -> Bool }
-- This is a little bit of a hack. Ideally instances would match when the
-- predicate is polymorphic, but that doesn't work since the polymorphic type
-- may have to unify with multiple distict values.
--
-- It may however be possible to define a MPTC from monomorphic to polymorphic
-- datatypes to avoid this issue.
instance {-# OVERLAPPING #-}
HasPredicate (Either ServantError Void ': xs) (Either ServantError a) where
getPredicate (HCons f _) x = case x of
Left e -> f (Left e)
Right _ -> True
instance {-# OVERLAPPING #-} (ctx a)
=> HasPredicate (Constraint ctx ': xs) (Either ServantError a) where
getPredicate (HConsC f _) x = case x of
Left _ -> discard -- Not clear whether checking for FailureResponse is better
Right v -> getConstraint f v
getPredicate (HCons _ _) _ = error "not impossible, but non-sensical"
instance {-# OVERLAPPABLE #-} (ls ~ (b ': xs), HasPredicate xs a)
=> HasPredicate ls a where
getPredicate (HCons _ xs) = getPredicate xs
getPredicate _ = error "impossible"
-- | Add a predicate to a list of predicates. Note that the predicate may not
-- be polymorphic.
addPredicate :: (a -> Bool) -> Predicates b -> Predicates (a ': b)
addPredicate = HCons
-- | Add a predicate with a class constraint.
--
-- Note that every possible argument must be an instance of that class for this
-- to typecheck. In other words, if the @Predicates@ is being used for return
-- types, every return type in the API must be an instance of the class. If
-- it's being used for filtering, every capture, header, body, etc. type must
-- be an instance of that class.
--
-- This can be used to for example test that returned JSON has certain
-- properties, or (via generics) that if any datatype contains a (possibly
-- nested) field of a particular type, it always meets certain properties.
addPolyPredicate :: proxy ctx -> (forall a. ctx a => a -> Bool) -> Predicates b
-> Predicates (Constraint ctx ': b)
addPolyPredicate _ p = HConsC (Constraint p)
-- | Given a predicate over an @p :: a -> Bool@, add a predicate to the @Predicates@
-- list that succeeds on an @val :: Either ServantError a@ if @val@ is a
-- @Left@, or a @Right v@ such that @p a == True@.
addRightPredicate :: (a -> Bool) -> Predicates b -> Predicates (Either ServantError a ': b)
addRightPredicate p = addPredicate $ either (const True) p
-- | The @Left@ analog of 'addRightPredicate'.
addLeftPredicate :: (ServantError -> Bool) -> Predicates b
-> Predicates (Either ServantError Void ': b)
addLeftPredicate p = addPredicate $ either p (error "impossible")
-- | An empty list of predicates. This doesn't discard any values when used as
-- a filter, and doesn't fail any value when used as a condition to satisfy.
emptyPredicates :: Predicates '[]
emptyPredicates = HNil
-- * Useful predicates
-- | A @Predicates@ list that fails a test if the response is an HTTP 500 error.
never500s :: Predicates '[Either ServantError Void]
never500s = addLeftPredicate go emptyPredicates
where
go (FailureResponse x _ _) = statusCode x /= 500
go _ = True
-- | A @Predicates@ list that fails a test if the response is anything but a
-- top-level object (e.g., if it is an array or literal).
--
-- Returning anything other than object is considered bad practice, as
--
-- (1) it is hard to modify the returned value while maintaining backwards
-- compatibility;
-- (2) many older tools do not support top-level arrays;
-- (3) whether top-level numbers, booleans, or strings are valid JSON depends
-- on what RFC you're going by;
-- (4) there are security issues with top-level arrays.
onlyJsonObjects :: Predicates '[Constraint ToJSON]
onlyJsonObjects = addPolyPredicate (Proxy :: Proxy ToJSON) go emptyPredicates
where
go x = case toJSON x of
Object _ -> True
_ -> False

159
src/Servant/QuickCheck/Internal/QuickCheck.hs Normal file
View File

@ -0,0 +1,159 @@
-- | This module contains wrappers around lower-level functionality.
module Servant.QuickCheck.Internal.QuickCheck where
import Control.Concurrent (threadDelay)
import Control.Concurrent.MVar (modifyMVar_, readMVar)
import Control.Monad (replicateM_)
import Data.Proxy (Proxy)
import Data.Void (Void)
import Network.HTTP.Client (Manager, defaultManagerSettings,
newManager)
import Network.HTTP.Client (managerModifyRequest, getUri)
import Network.Wai.Handler.Warp (withApplication)
import Servant (HasServer, Server, serve)
import Servant.Client (BaseUrl (..), Client, HasClient,
Scheme (..), ServantError, client)
import System.IO (hPutStrLn, hFlush)
import System.IO.Temp (withSystemTempFile)
import System.Mem (performGC)
import System.Process (callCommand)
import Test.Hspec (Expectation, expectationFailure)
import Test.QuickCheck (Args (..), Property, Result (..),
Testable, property,
quickCheckWithResult, stdArgs)
import Servant.QuickCheck.Internal.Testable
import Servant.QuickCheck.Internal.Predicates
import Servant.QuickCheck.Internal.Benchmarking
-- | Start a servant application on an open port, run the provided function,
-- then stop the application.
withServantServer :: HasServer a '[] => Proxy a -> IO (Server a)
-> (BaseUrl -> IO r) -> IO r
withServantServer api server t
= withApplication (return . serve api =<< server) $ \port ->
t (BaseUrl Http "localhost" port "")
-- | A QuickCheck 'Property' that randomly generates arguments (captures, query
-- params, request bodies, headers, etc.) expected by endpoints of a server,
-- and makes requests to the servers running in the two provided URLs in the
-- same order, failing if they do not return the same response.
--
-- Evidently, if the behaviour of the server is expected to be
-- non-deterministic, this function may produce spurious failures.
--
-- Note that this QuickCheck 'Property' does IO; interleaving it with other IO
-- actions will not work. It is provided so that it can be used with QuickCheck
-- functions such as 'quickCheckWith'. For most use cases, you should use
-- @serversEqual@ or @servantServersEqual@.
serversEqualProperty :: (HasClient a, Testable (ShouldMatch (Client a)))
=> Proxy a -> Manager -> BaseUrl -> BaseUrl -> Property
serversEqualProperty api mgr burl1 burl2 = property $ ShouldMatch c1 c2
where c1 = client api burl1 mgr
c2 = client api burl2 mgr
-- | Check that the two servers running under the provided @BaseUrl@s behave
-- identically by randomly generating arguments (captures, query params, request bodies,
-- headers, etc.) expected by the server. If, given the same request, the
-- response is not the same (according to the definition of @==@ for the return
-- datatype), the 'Expectation' fails, printing the counterexample.
--
-- The @Int@ argument specifies maximum number of test cases to generate and
-- run.
--
-- Evidently, if the behaviour of the server is expected to be
-- non-deterministic, this function may produce spurious failures.
serversEqual :: (HasClient a, Testable (ShouldMatch (Client a)))
=> Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
serversEqual api burl1 burl2 tries = do
mgr <- managerWithStoredReq
let args = stdArgs { chatty = False, maxSuccess = tries }
res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
case res of
Success _ _ _ -> return ()
_ -> prettyErr >>= expectationFailure
serverSatisfiesProperty :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
=> Proxy a -> Manager -> BaseUrl -> Predicates filt -> Predicates exp -> Property
serverSatisfiesProperty api mgr burl filters expect = do
property $ ShouldSatisfy (client api burl mgr) filters expect
-- | Check that a server's responses satisfies certain properties.
serverSatisfies :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
=> Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
-> Int -> Expectation
serverSatisfies api burl filters expect tries = do
mgr <- managerWithStoredReq
let args = stdArgs { chatty = False, maxSuccess = tries }
res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
case res of
Success _ _ _ -> return ()
GaveUp n _ _ -> expectationFailure $ "Gave up after " ++ show n ++ " tests"
_ -> prettyErr >>= expectationFailure
-- | Check that the two servers running under the provided @BaseUrl@s do not
-- behave identically.
--
-- As with @serversEqualProperty@, non-determinism in the servers will likely
-- result in failures that may not be significant.
serversUnequal :: (HasClient a, Testable (ShouldMatch (Client a)))
=> Proxy a -> BaseUrl -> BaseUrl -> Int -> Expectation
serversUnequal api burl1 burl2 tries = do
mgr <- managerWithStoredReq
let args = stdArgs { chatty = False, maxSuccess = tries }
res <- quickCheckWithResult args $ serversEqualProperty api mgr burl1 burl2
case res of
Success _ _ _ -> prettyErr >>= expectationFailure
_ -> return ()
serverDoesntSatisfy :: (HasClient a, Testable (ShouldSatisfy filt exp (Client a)))
=> Proxy a -> BaseUrl -> Predicates filt -> Predicates exp
-> Int -> Expectation
serverDoesntSatisfy api burl filters expect tries = do
mgr <- managerWithStoredReq
let args = stdArgs { chatty = False, maxSuccess = tries }
res <- quickCheckWithResult args $ serverSatisfiesProperty api mgr burl filters expect
case res of
Success _ _ _ -> prettyErr >>= expectationFailure
_ -> return ()
-- | Benchmarks a server with arbitrary requests using 'wrk'.
--
-- When using this, you should compile your program with '-threaded'.
-- Moreover, 'wrk' must be in the @$PATH@.
--
-- Note that this function is still very experimental, and it's behaviour will
-- likely change.
serverBenchmark ::
(HasClient a , Testable (ShouldSatisfy '[] '[Either ServantError Void] (Client a)))
=> Proxy a -> BaseUrl -> BenchOptions -> IO ()
serverBenchmark api burl opts = replicateM_ (noOfTests opts) go
where
go = do
let alwaysTrue = addLeftPredicate (const True) emptyPredicates
serverSatisfies api burl emptyPredicates alwaysTrue 1
Just (r, _) <- readMVar currentReq
withSystemTempFile "wrkscript.lua" $ \f h -> do
let url = show $ getUri r
s = mkScript $ reqToWrk r
c = "wrk -c" ++ show (connections opts)
++ " -d" ++ show (duration opts) ++ "s "
++ " -t" ++ show (threads opts)
++ " -s \"" ++ f ++ "\" "
++ " --latency "
++ url
hPutStrLn h s
hFlush h
callCommand c
-- While running wrk and the server on the same machine make the
-- results much less meaningful, this ameliorates the situation
-- somewhat.
performGC
threadDelay 1000
managerWithStoredReq :: IO Manager
managerWithStoredReq = newManager defaultManagerSettings { managerModifyRequest = go }
where go req = modifyMVar_ currentReq (addReq req) >> return req
addReq req _ = return $ Just (req, "")

96
src/Servant/QuickCheck/Internal/Testable.hs Normal file
View File

@ -0,0 +1,96 @@
-- | This module contains QuickCheck-related logic.
module Servant.QuickCheck.Internal.Testable where
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, readMVar)
import Control.Monad.Except (runExceptT)
import GHC.Generics (Generic)
import Network.HTTP.Client (Request, RequestBody (..),
requestBody)
import Servant.API ((:<|>)(..))
import Servant.Client (ServantError (..), ClientM)
import System.IO.Unsafe (unsafePerformIO)
import Test.QuickCheck (Arbitrary (..), discard)
import Test.QuickCheck.Property (Testable (..), forAllShrink,
ioProperty, (.&.))
import Servant.QuickCheck.Internal.Predicates
-- * ShouldMatch
-- | Two corresponding client functions. Used for checking that APIs match.
data ShouldMatch a = ShouldMatch a a
deriving (Eq, Show, Read, Generic)
instance (Show a, Eq a) => Testable (ShouldMatch (ClientM a)) where
property (ShouldMatch e1 e2) = ioProperty $ do
e1' <- runExceptT e1
e2' <- runExceptT e2
modifyMVar_ currentReq $ \x -> case x of
Nothing -> error "impossible"
Just (x', _) -> return $ Just (x', "LHS:\n" ++ show e1'
++ "\nRHS:\n" ++ show e2')
case (e1', e2') of
(Right v1, Right v2) -> return $ v1 == v2
(Left (FailureResponse a1 b1 c1), Left (FailureResponse a2 b2 c2)) ->
return $ a1 == a2 && b1 == b2 && c1 == c2
(err1, err2) -> error $ "Exception response:"
++ "\nLHS:\n" ++ show err1
++ "\nRHS:\n" ++ show err2
instance (Arbitrary a, Show a, Testable (ShouldMatch b))
=> Testable (ShouldMatch (a -> b)) where
property (ShouldMatch f1 f2) = forAllShrink arbitrary shrink go
where go x = ShouldMatch (f1 x) (f2 x)
instance (Testable (ShouldMatch a), Testable (ShouldMatch b))
=> Testable (ShouldMatch (a :<|> b)) where
property (ShouldMatch (a1 :<|> b1) (a2 :<|> b2))
= property (ShouldMatch a1 a2) .&. property (ShouldMatch b1 b2)
-- * ShouldSatisfy
data ShouldSatisfy filter expect a = ShouldSatisfy
{ ssVal :: a
, ssFilter :: Predicates filter
, ssExpect :: Predicates expect
} deriving (Functor)
instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
=> Testable (ShouldSatisfy filter expect (ClientM a)) where
property (ShouldSatisfy a _ e) = ioProperty $ do
a' <- runExceptT a
modifyMVar_ currentReq $ \x -> case x of
Nothing -> error "impossible"
Just (x', _) -> return $ Just (x', show a')
return $ getPredicate e a'
instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
, HasPredicate filter a)
=> Testable (ShouldSatisfy filter expect (a -> b)) where
property (ShouldSatisfy g f e) = forAllShrink arbitrary shrink go
where go x | getPredicate f x = ShouldSatisfy (g x) f e
| otherwise = discard
instance ( Testable (ShouldSatisfy filter expect a)
, Testable (ShouldSatisfy filter expect b))
=> Testable (ShouldSatisfy filter expect (a :<|> b)) where
property (ShouldSatisfy (a :<|> b) f e)
= property (ShouldSatisfy a f e) .&. property (ShouldSatisfy b f e)
-- * Utils
-- Used to store the current request and response so that in case of failure we
-- have the failing test in a user-friendly form.
currentReq :: MVar (Maybe (Request, String))
currentReq = unsafePerformIO $ newMVar Nothing
{-# NOINLINE currentReq #-}
prettyErr :: IO String
prettyErr = do
Just (req, resp) <- readMVar currentReq
return $ show req ++ "Body:\n" ++ showReqBody (requestBody req)
++ "\n\nResponse:\n" ++ resp
where
showReqBody (RequestBodyLBS x) = show x
showReqBody _ = error "expecting RequestBodyLBS"

36
stack.yaml Normal file
View File

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

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

170
test/Servant/CoMock/InternalSpec.hs Normal file
View File

@ -0,0 +1,170 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.CoMock.InternalSpec (spec) where
import Control.Concurrent.MVar (newMVar, readMVar, swapMVar)
import Control.Monad.IO.Class (liftIO)
import Data.Proxy
import Servant
import Test.Hspec
import Servant.CoMock.Internal
spec :: Spec
spec = do
serversEqualSpec
serverSatisfiesSpec
serverBenchmarkSpec
serversEqualSpec :: Spec
serversEqualSpec = describe "serversEqual" $ do
context "servers without function types" $ do
it "considers equal servers equal" $ do
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
serversEqual onlyReturnAPI burl burl noOfTestCases
it "considers unequal servers unequal" $ do
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl1 ->
withServantServer onlyReturnAPI onlyReturnAPIServer' $ \burl2 ->
serversUnequal onlyReturnAPI burl1 burl2 noOfTestCases
context "servers with function types" $ do
it "considers equal servers equal" $ do
withServantServer functionAPI functionAPIServer $ \burl ->
serversEqual functionAPI burl burl noOfTestCases
it "considers unequal servers unequal" $ do
withServantServer functionAPI functionAPIServer $ \burl1 ->
withServantServer functionAPI functionAPIServer' $ \burl2 ->
serversUnequal functionAPI burl1 burl2 noOfTestCases
context "stateful servers" $ do
it "considers equal servers equal" $ do
withServantServer statefulAPI statefulAPIServer $ \burl1 ->
withServantServer statefulAPI statefulAPIServer $ \burl2 ->
serversEqual statefulAPI burl1 burl2 noOfTestCases
serverSatisfiesSpec :: Spec
serverSatisfiesSpec = describe "serverSatisfies" $ do
it "passes true predicates" $ do
let e = addRightPredicate (== (5 :: Int)) emptyPredicates
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
serverSatisfies onlyReturnAPI burl emptyPredicates e noOfTestCases
it "fails false predicates" $ do
let e = addRightPredicate (== (4 :: Int)) emptyPredicates
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates e noOfTestCases
it "allows filtering" $ do
let f = addPredicate (\(x :: String) -> length x > 2) emptyPredicates
e = addRightPredicate (\(x :: Int) -> x > 2) emptyPredicates
e' = addRightPredicate (\(x :: Int) -> x < 2) emptyPredicates
withServantServer functionAPI functionAPIServer $ \burl -> do
serverSatisfies functionAPI burl f e noOfTestCases
serverDoesntSatisfy functionAPI burl f e' noOfTestCases
it "allows polymorphic predicates" $ do
let p1 x = length (show x) < 100000
p2 x = length (show x) < 1
e1 = addPolyPredicate (Proxy :: Proxy Show) p1 emptyPredicates
e2 = addPolyPredicate (Proxy :: Proxy Show) p2 emptyPredicates
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl -> do
serverSatisfies onlyReturnAPI burl emptyPredicates e1 noOfTestCases
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates e2 noOfTestCases
context "never500s" $ do
it "is true for servers that don't return 500s" $ do
withServantServer functionAPI functionAPIServer $ \burl ->
serverSatisfies functionAPI burl emptyPredicates never500s noOfTestCases
it "is false for servers that return 500s" $ do
withServantServer onlyReturnAPI onlyReturnAPIServer'' $ \burl ->
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates never500s noOfTestCases
context "onlyJsonObjects" $ do
it "is false for servers that return top-level literals" $ do
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
serverDoesntSatisfy onlyReturnAPI burl emptyPredicates onlyJsonObjects noOfTestCases
serverBenchmarkSpec :: Spec
serverBenchmarkSpec = describe "serverBenchmark" $ do
it "works" $ do
withServantServer onlyReturnAPI onlyReturnAPIServer $ \burl ->
serverBenchmark onlyReturnAPI burl defaultBenchOptions
------------------------------------------------------------------------------
-- APIs
------------------------------------------------------------------------------
-- * OnlyReturn
type OnlyReturnAPI = Get '[JSON] Int
:<|> Post '[JSON] String
onlyReturnAPI :: Proxy OnlyReturnAPI
onlyReturnAPI = Proxy
onlyReturnAPIServer :: IO (Server OnlyReturnAPI)
onlyReturnAPIServer = return $ return 5 :<|> return "hi"
onlyReturnAPIServer' :: IO (Server OnlyReturnAPI)
onlyReturnAPIServer' = return $ return 5 :<|> return "hia"
onlyReturnAPIServer'' :: IO (Server OnlyReturnAPI)
onlyReturnAPIServer'' = return $ error "err" :<|> return "hia"
-- * Function
type FunctionAPI = ReqBody '[JSON] String :> Post '[JSON] Int
:<|> Header "X-abool" Bool :> Get '[JSON] (Maybe Bool)
functionAPI :: Proxy FunctionAPI
functionAPI = Proxy
functionAPIServer :: IO (Server FunctionAPI)
functionAPIServer = return $ return . length :<|> return
functionAPIServer' :: IO (Server FunctionAPI)
functionAPIServer'
= return $ (\x -> return $ length x - 1) :<|> \x -> return (not <$> x)
-- * Stateful
type StatefulAPI = ReqBody '[JSON] String :> Post '[JSON] String
:<|> Get '[JSON] Int
statefulAPI :: Proxy StatefulAPI
statefulAPI = Proxy
statefulAPIServer :: IO (Server StatefulAPI)
statefulAPIServer = do
mvar <- newMVar ""
return $ (\x -> liftIO $ swapMVar mvar x)
:<|> (liftIO $ readMVar mvar >>= return . length)
------------------------------------------------------------------------------
-- Utils
------------------------------------------------------------------------------
noOfTestCases :: Int
#if LONG_TESTS
noOfTestCases = 20000
#else
noOfTestCases = 500
#endif

1
test/Spec.hs Normal file
View File

@ -0,0 +1 @@
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}