commit 72abea9b0f31c22076a93a7d0b728ca98645d943 Author: Julian K. Arni Date: Fri Apr 22 13:00:23 2016 +0200 initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9638ef2 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +doc/_build/ diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..8a1cb24 --- /dev/null +++ b/.travis.yml @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..c4a51a2 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/LICENSE b/doc/LICENSE new file mode 100644 index 0000000..c4a51a2 --- /dev/null +++ b/doc/LICENSE @@ -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. diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 0000000..95957c1 --- /dev/null +++ b/doc/Makefile @@ -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 ' where 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." diff --git a/doc/ServersEqual.lhs b/doc/ServersEqual.lhs new file mode 100644 index 0000000..b90e300 --- /dev/null +++ b/doc/ServersEqual.lhs @@ -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[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 +``` + + diff --git a/doc/Setup.hs b/doc/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/doc/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/conf.py b/doc/conf.py new file mode 100644 index 0000000..8c2882c --- /dev/null +++ b/doc/conf.py @@ -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 +# " v 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 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, +} diff --git a/doc/doc.cabal b/doc/doc.cabal new file mode 100644 index 0000000..39b2433 --- /dev/null +++ b/doc/doc.cabal @@ -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 diff --git a/doc/index.rst b/doc/index.rst new file mode 100644 index 0000000..5f3635c --- /dev/null +++ b/doc/index.rst @@ -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 diff --git a/doc/requirements.txt b/doc/requirements.txt new file mode 100644 index 0000000..0c9c95a --- /dev/null +++ b/doc/requirements.txt @@ -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 diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal new file mode 100644 index 0000000..6cf775d --- /dev/null +++ b/servant-quickcheck.cabal @@ -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 diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs new file mode 100644 index 0000000..c9a3d49 --- /dev/null +++ b/src/Servant/QuickCheck.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal.hs b/src/Servant/QuickCheck/Internal.hs new file mode 100644 index 0000000..7178e62 --- /dev/null +++ b/src/Servant/QuickCheck/Internal.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/Benchmarking.hs b/src/Servant/QuickCheck/Internal/Benchmarking.hs new file mode 100644 index 0000000..0c8abc3 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/Benchmarking.hs @@ -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)-} diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs new file mode 100644 index 0000000..f50aedc --- /dev/null +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -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 diff --git a/src/Servant/QuickCheck/Internal/QuickCheck.hs b/src/Servant/QuickCheck/Internal/QuickCheck.hs new file mode 100644 index 0000000..68d28c4 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/QuickCheck.hs @@ -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, "") diff --git a/src/Servant/QuickCheck/Internal/Testable.hs b/src/Servant/QuickCheck/Internal/Testable.hs new file mode 100644 index 0000000..ee0aad1 --- /dev/null +++ b/src/Servant/QuickCheck/Internal/Testable.hs @@ -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" diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..c9ce168 --- /dev/null +++ b/stack.yaml @@ -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 diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 index 0000000..b6f23e5 --- /dev/null +++ b/test/Doctest.hs @@ -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 diff --git a/test/Servant/CoMock/InternalSpec.hs b/test/Servant/CoMock/InternalSpec.hs new file mode 100644 index 0000000..34b09d4 --- /dev/null +++ b/test/Servant/CoMock/InternalSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}