diff --git a/.ghci b/.ghci deleted file mode 100644 index 93d9b991..00000000 --- a/.ghci +++ /dev/null @@ -1 +0,0 @@ -:set -itest -isrc -packagehspec2 diff --git a/.gitignore b/.gitignore index 2b2f3487..163de4bd 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,7 @@ Setup .stack-work shell.nix default.nix +doc/_build +doc/venv +doc/tutorial/static/api.js +doc/tutorial/static/jq.js diff --git a/.travis.yml b/.travis.yml index 1c45c6fa..b2bad73b 100644 --- a/.travis.yml +++ b/.travis.yml @@ -34,7 +34,7 @@ install: script: - if [ "$GHCJS" = "true" ]; then ./.travis-ghcjs.sh ; - else ./.travis-ghc.sh ; + else ./travis.sh ; fi - export CASHER_TIME_OUT=500 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000..c4eb4705 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,86 @@ +# Contributing Guidelines + +Contributions are very welcome! To hack on the github version, clone the +repository. You can use `cabal`: + +```shell +./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages +./scripts/test-all.sh # Run all the tests +``` + +`stack`: + +```shell +stack build # Install and build packages +stack test # Run all the tests +``` + +Or `nix`: +```shell +./scripts/generate-nix-files.sh # Get up-to-date shell.nix files +``` + + +## General + +Some things we like: + +- Explicit imports +- Upper and lower bounds for packages +- Few dependencies +- -Werror-compatible (for both 7.8 and 7.10) + +Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` +files in the repository provide a good baseline for consistency. + +Please include a description of the changes in your PR in the `CHANGELOG.md` of +the packages you've changed. And of course, write tests! + +## PR process + +We try to give timely reviews to PRs that pass CI. If CI for your PR fails, we +may close the PR if it has been open for too long (though you should feel free +to reopen when the issues have been fixed). + +We require two +1 from the maintainers of the repo. If you feel like there has +not been a timely response to a PR, you can ping the Maintainers group (with +`@haskell-servant/maintainers`). + +## New combinators + +We encourage people to experiment with new combinators and instances - it is +one of the most powerful ways of using `servant`, and a wonderful way of +getting to know it better. If you do write a new combinator, we would love to +know about it! Either hop on #servant on freenode and let us know, or open an +issue with the `news` tag (which we will close when we read it). + +As for adding them to the main repo: maintaining combinators can be expensive, +since official combinators must have instances for all classes (and new classes +come along fairly frequently). We therefore have to be quite selective about +those that we accept. If you're considering writing a new combinator, open an +issue to discuss it first! (You could release your combinator as a separate +package, of course.) + + +## New classes + +The main benefit of having a new class and package in the main servant repo is +that we get to see via CI whether changes to other packages break the build. +Open an issue to discuss whether a package should be added to the main repo. If +we decide that it can, you can still keep maintainership over it. + +Whether or not you want your package to be in the repo, create an issue with +the `news` label if you make a new package so we can know about it! + +## Release policy + +We are currently moving to a more aggresive release policy, so that you can get +what you contribute from Hackage fairly soon. However, note that prior to major +releases it may take some time in between releases. + +## Reporting security issues + +Please email haskell-servant-maintainers AT googlegroups DOT com. This group is +private, and accessible only to known maintainers. We will then discuss how to +proceed. Please do not make the issue public before we inform you that we have +a patch ready. diff --git a/README.md b/README.md index 0f13f495..3cf786ea 100644 --- a/README.md +++ b/README.md @@ -17,29 +17,4 @@ list](https://groups.google.com/forum/#!forum/haskell-servant). ## Contributing -Contributions are very welcome! To hack on the github version, clone the -repository. You can use `cabal`: - -```shell -./scripts/start-sandbox.sh # Initialize the sandbox and add-source the packages -./scripts/test-all.sh # Run all the tests -``` - -`stack`: - -```shell -stack build # Install and build packages -stack test # Run all the tests -``` - -Or `nix`: -```shell -./scripts/generate-nix-files.sh # Get up-to-date shell.nix files -``` - -Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` -files in the repository provide a good baseline for consistency. - -Please include a description of the changes in your PR in the `CHANGELOG.md` of -the packages you've changed. And of course, write tests! - +See `CONTRIBUTING.md` diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 00000000..95957c1a --- /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/building-the-docs b/doc/building-the-docs new file mode 100644 index 00000000..34f8b16f --- /dev/null +++ b/doc/building-the-docs @@ -0,0 +1,8 @@ +To build the docs locally: + +$ virtualenv venv +$ . ./venv/bin/activate +$ pip install -r requirements.txt +$ make html + +Docs will be built in _build/html/index.html . diff --git a/doc/conf.py b/doc/conf.py new file mode 100644 index 00000000..1c7aba02 --- /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' +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.tex', u'servant 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', u'servant 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', u'servant Documentation', + author, 'servant', '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/index.rst b/doc/index.rst new file mode 100644 index 00000000..eebba2dd --- /dev/null +++ b/doc/index.rst @@ -0,0 +1,22 @@ +servant – A Type-Level Web DSL +============================== + +.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png + +**servant** is a set of packages for declaring web APIs at the type-level and +then using those API specifications to: + +- write servers (this part of **servant** can be considered a web framework), +- obtain client functions (in haskell), +- generate client functions for other programming languages, +- generate documentation for your web applications +- and more... + +All in a type-safe manner. + +.. toctree:: + :maxdepth: 2 + + introduction.rst + tutorial/index.rst + links.rst diff --git a/doc/introduction.rst b/doc/introduction.rst new file mode 100644 index 00000000..77ef306b --- /dev/null +++ b/doc/introduction.rst @@ -0,0 +1,40 @@ +Introduction +------------ + +**servant** has the following guiding principles: + +- concision + + This is a pretty wide-ranging principle. You should be able to get nice + documentation for your web servers, and client libraries, without repeating + yourself. You should not have to manually serialize and deserialize your + resources, but only declare how to do those things *once per type*. If a + bunch of your handlers take the same query parameters, you shouldn't have to + repeat that logic for each handler, but instead just "apply" it to all of + them at once. Your handlers shouldn't be where composition goes to die. And + so on. + +- flexibility + + If we haven't thought of your use case, it should still be easily + achievable. If you want to use templating library X, go ahead. Forms? Do + them however you want, but without difficulty. We're not opinionated. + +- separation of concerns + + Your handlers and your HTTP logic should be separate. True to the philosphy + at the core of HTTP and REST, with **servant** your handlers return normal + Haskell datatypes - that's the resource. And then from a description of your + API, **servant** handles the *presentation* (i.e., the Content-Types). But + that's just one example. + +- type safety + + Want to be sure your API meets a specification? Your compiler can check + that for you. Links you can be sure exist? You got it. + +To stick true to these principles, we do things a little differently than you +might expect. The core idea is *reifying the description of your API*. Once +reified, everything follows. We think we might be the first web framework to +reify API descriptions in an extensible way. We're pretty sure we're the first +to reify it as *types*. diff --git a/doc/links.rst b/doc/links.rst new file mode 100644 index 00000000..5f14c527 --- /dev/null +++ b/doc/links.rst @@ -0,0 +1,34 @@ + +Helpful Links +------------- + +- the central documentation (this site): + `haskell-servant.readthedocs.org `_ + +- the github repo: + `github.com/haskell-servant/servant `_ + +- the issue tracker (Feel free to create issues and submit PRs!): + `https://github.com/haskell-servant/servant/issues `_ + +- the irc channel: + ``#servant`` on freenode + +- the mailing list: + `groups.google.com/forum/#!forum/haskell-servant `_ + +- blog posts and videos and slides of some talks on servant: + `haskell-servant.github.io `_ + +- the servant packages on hackage: + + - `hackage.haskell.org/package/servant `_ + - `hackage.haskell.org/package/servant-server `_ + - `hackage.haskell.org/package/servant-client `_ + - `hackage.haskell.org/package/servant-blaze `_ + - `hackage.haskell.org/package/servant-lucid `_ + - `hackage.haskell.org/package/servant-cassava `_ + - `hackage.haskell.org/package/servant-docs `_ + - `hackage.haskell.org/package/servant-foreign `_ + - `hackage.haskell.org/package/servant-js `_ + - `hackage.haskell.org/package/servant-mock `_ diff --git a/doc/requirements.txt b/doc/requirements.txt new file mode 100644 index 00000000..0c9c95a8 --- /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/doc/tutorial/.ghci b/doc/tutorial/.ghci new file mode 100644 index 00000000..d8e88521 --- /dev/null +++ b/doc/tutorial/.ghci @@ -0,0 +1 @@ +:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing -itest diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs new file mode 100644 index 00000000..54022bb8 --- /dev/null +++ b/doc/tutorial/ApiType.lhs @@ -0,0 +1,339 @@ +# A web API as a type + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module ApiType where + +import Data.Text +import Servant.API +``` + +Consider the following informal specification of an API: + + > The endpoint at `/users` expects a GET request with query string parameter + > `sortby` whose value can be one of `age` or `name` and returns a + > list/array of JSON objects describing users, with fields `age`, `name`, + > `email`, `registration_date`". + +You *should* be able to formalize that. And then use the formalized version to +get you much of the way towards writing a web app. And all the way towards +getting some client libraries, and documentation, and more. + +How would we describe it with **servant**? An endpoint description is a good old +Haskell **type**: + +``` haskell +type UserAPI = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] + +data SortBy = Age | Name + +data User = User { + name :: String, + age :: Int +} +``` + +Let's break that down: + +- `"users"` says that our endpoint will be accessible under `/users`; +- `QueryParam "sortby" SortBy`, where `SortBy` is defined by `data SortBy = Age | Name`, + says that the endpoint has a query string parameter named `sortby` + whose value will be extracted as a value of type `SortBy`. +- `Get '[JSON] [User]` says that the endpoint will be accessible through HTTP + GET requests, returning a list of users encoded as JSON. You will see + later how you can make use of this to make your data available under different + formats, the choice being made depending on the [Accept + header](http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html) specified in + the client's request. +- The `:>` operator that separates the various "combinators" just lets you + sequence static path fragments, URL captures and other combinators. The + ordering only matters for static path fragments and URL captures. `"users" :> + "list-all" :> Get '[JSON] [User]`, equivalent to `/users/list-all`, is + obviously not the same as `"list-all" :> "users" :> Get '[JSON] [User]`, which + is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow + equivalent to `/`, but sometimes it just lets you chain another combinator. + +We can also describe APIs with multiple endpoints by using the `:<|>` +combinators. Here's an example: + +``` haskell +type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User] + :<|> "list-all" :> "users" :> Get '[JSON] [User] +``` + +**servant** provides a fair amount of combinators out-of-the-box, but you can +always write your own when you need it. Here's a quick overview of the most +often needed the combinators that **servant** comes with. + +## Combinators + +### Static strings + +As you've already seen, you can use type-level strings (enabled with the +`DataKinds` language extension) for static path fragments. Chaining +them amounts to `/`-separating them in a URL. + +``` haskell +type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User] + -- describes an endpoint reachable at: + -- /users/list-all/now +``` + +### `Delete`, `Get`, `Patch`, `Post` and `Put` + +The `Get` combinator is defined in terms of the more general `Verb`: +``` haskell ignore +data Verb method (statusCode :: Nat) (contentType :: [*]) a +type Get = Verb 'GET 200 +``` + +There are other predefined type synonyms for other common HTTP methods, +such as e.g.: +``` haskell ignore +type Delete = Verb 'DELETE 200 +type Patch = Verb 'PATCH 200 +type Post = Verb 'POST 200 +type Put = Verb 'PUT 200 +``` + +There are also variants that do not return a 200 status code, such +as for example: +``` haskell ignore +type PostCreated = Verb 'POST 201 +type PostAccepted = Verb 'POST 202 +``` + +An endpoint always ends with a variant of the `Verb` combinator +(unless you write your own combinators). Examples: + +``` haskell +type UserAPI4 = "users" :> Get '[JSON] [User] + :<|> "admins" :> Get '[JSON] [User] +``` + +### `Capture` + +URL captures are segments of the path of a URL that are variable and whose actual value is +captured and passed to the request handlers. In many web frameworks, you'll see +it written as in `/users/:userid`, with that leading `:` denoting that `userid` +is just some kind of variable name or placeholder. For instance, if `userid` is +supposed to range over all integers greater or equal to 1, our endpoint will +match requests made to `/users/1`, `/users/143` and so on. + +The `Capture` combinator in **servant** takes a (type-level) string representing +the "name of the variable" and a type, which indicates the type we want to +decode the "captured value" to. + +``` haskell ignore +data Capture (s :: Symbol) a +-- s :: Symbol just says that 's' must be a type-level string. +``` + +In some web frameworks, you use regexes for captures. We use a +[`FromHttpApiData`](https://hackage.haskell.org/package/http-api-data/docs/Web-HttpApiData.html#t:FromHttpApiData) +class, which the captured value must be an instance of. + +Examples: + +``` haskell +type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User + -- equivalent to 'GET /user/:userid' + -- except that we explicitly say that "userid" + -- must be an integer + + :<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent + -- equivalent to 'DELETE /user/:userid' +``` + +In the second case, `DeleteNoContent` specifies a 204 response code, +`JSON` specifies the content types on which the handler will match, +and `NoContent` says that the response will always be empty. + +### `QueryParam`, `QueryParams`, `QueryFlag` + +`QueryParam`, `QueryParams` and `QueryFlag` are about parameters in the query string, +i.e., those parameters that come after the question mark +(`?`) in URLs, like `sortby` in `/users?sortby=age`, whose value is +set to `age`. `QueryParams` lets you specify that the query parameter +is actually a list of values, which can be specified using +`?param=value1¶m=value2`. This represents a list of values +composed of `value1` and `value2`. `QueryFlag` lets you specify a +boolean-like query parameter where a client isn't forced to specify a +value. The absence or presence of the parameter's name in the query +string determines whether the parameter is considered to have the +value `True` or `False`. For instance, `/users?active` would list only +active users whereas `/users` would list them all. + +Here are the corresponding data type declarations: + +``` haskell ignore +data QueryParam (sym :: Symbol) a +data QueryParams (sym :: Symbol) a +data QueryFlag (sym :: Symbol) +``` + +Examples: + +``` haskell +type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User] + -- equivalent to 'GET /users?sortby={age, name}' + +``` + +Again, your handlers don't have to deserialize these things (into, for example, +a `SortBy`). **servant** takes care of it. + +### `ReqBody` + +Each HTTP request can carry some additional data that the server can use in its +*body*, and this data can be encoded in any format -- as long as the server +understands it. This can be used for example for an endpoint for creating new +users: instead of passing each field of the user as a separate query string +parameter or something dirty like that, we can group all the data into a JSON +object. This has the advantage of supporting nested objects. + +**servant**'s `ReqBody` combinator takes a list of content types in which the +data encoded in the request body can be represented and the type of that data. +And, as you might have guessed, you don't have to check the content type +header, and do the deserialization yourself. We do it for you. And return `Bad +Request` or `Unsupported Content Type` as appropriate. + +Here's the data type declaration for it: + +``` haskell ignore +data ReqBody (contentTypes :: [*]) a +``` + +Examples: + +``` haskell +type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User + -- - equivalent to 'POST /users' with a JSON object + -- describing a User in the request body + -- - returns a User encoded in JSON + + :<|> "users" :> Capture "userid" Integer + :> ReqBody '[JSON] User + :> Put '[JSON] User + -- - equivalent to 'PUT /users/:userid' with a JSON + -- object describing a User in the request body + -- - returns a User encoded in JSON +``` + +### Request `Header`s + +Request headers are used for various purposes, from caching to carrying +auth-related data. They consist of a header name and an associated value. An +example would be `Accept: application/json`. + +The `Header` combinator in **servant** takes a type-level string for the header +name and the type to which we want to decode the header's value (from some +textual representation), as illustrated below: + +``` haskell ignore +data Header (sym :: Symbol) a +``` + +Here's an example where we declare that an endpoint makes use of the +`User-Agent` header which specifies the name of the software/library used by +the client to send the request. + +``` haskell +type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User] +``` + +### Content types + +So far, whenever we have used a combinator that carries a list of content +types, we've always specified `'[JSON]`. However, **servant** lets you use several +content types, and also lets you define your own content types. + +Four content types are provided out-of-the-box by the core **servant** package: +`JSON`, `PlainText`, `FormUrlEncoded` and `OctetStream`. If for some obscure +reason you wanted one of your endpoints to make your user data available under +those 4 formats, you would write the API type as below: + +``` haskell +type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User] +``` + +(There are other packages that provide other content types. For example +**servant-lucid** and **servant-blaze** allow to generate html pages (using +**lucid** and **blaze-html**) and both come with a content type for html.) + +We will further explain how these content types and your data types can play +together in the [section about serving an API](Server.html). + +### Response `Headers` + +Just like an HTTP request, the response generated by a webserver can carry +headers too. **servant** provides a `Headers` combinator that carries a list of +`Header` types and can be used by simply wrapping the "return type" of an endpoint +with it. + +``` haskell ignore +data Headers (ls :: [*]) a +``` + +If you want to describe an endpoint that returns a "User-Count" header in each +response, you could write it as below: + +``` haskell +type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User]) +``` + +### Basic Authentication + +Once you've established the basic routes and semantics of your API, it's time +to consider protecting parts of it. Authentication and authorization are broad +and nuanced topics; as servant began to explore this space we started small +with one of HTTP's earliest authentication schemes: [Basic +Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication). + +When protecting endpoints with basic authentication, we need to specify two items: + +1. The **realm** of authentication as per the Basic Authentictaion spec. +2. The datatype returned by the server after authentication is verified. This + is usually a `User` or `Customer` type datatype. + +With those two items in mind, *servant* provides the following combinator: + +``` haskell ignore +data BasicAuth (realm :: Symbol) (userData :: *) +``` + +Which is used like so: + +``` haskell +type ProtectedAPI12 + = UserAPI -- this is public + :<|> BasicAuth "my-real" User :> UserAPI2 -- this is protected by auth +``` + +### Interoperability with `wai`: `Raw` + +Finally, we also include a combinator named `Raw` that provides an escape hatch +to the underlying low-level web library `wai`. It can be used when +you want to plug a [wai `Application`](http://hackage.haskell.org/package/wai) +into your webservice: + +``` haskell +type UserAPI11 = "users" :> Get '[JSON] [User] + -- a /users endpoint + + :<|> Raw + -- requests to anything else than /users + -- go here, where the server will try to + -- find a file with the right name + -- at the right path +``` + +One example for this is if you want to serve a directory of static files along +with the rest of your API. But you can plug in everything that is an +`Application`, e.g. a whole web application written in any of the web +frameworks that support `wai`. diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs new file mode 100644 index 00000000..b9117e55 --- /dev/null +++ b/doc/tutorial/Authentication.lhs @@ -0,0 +1,427 @@ +# Authentication in Servant + +Once you've established the basic routes and semantics of your API, it's time +to consider protecting parts of it. Authentication and authorization are broad +and nuanced topics; as servant began to explore this space we started small +with one of HTTP's earliest authentication schemes: [Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication). + +Servant `0.5` shipped with out-of-the-box support for Basic Authentication. +However, we recognize that every web application is its own beautiful snowflake +and are offering experimental support for generalized or ad-hoc authentication. + +In this tutorial we'll build two APIs. One protecting certain routes with Basic +Authentication and another protecting the same routes with a custom, in-house +authentication scheme. + +## Basic Authentication + +When protecting endpoints with basic authentication, we need to specify two +items: + +1. The **realm** of authentication as per the Basic Authentication spec. +2. The datatype returned by the server after authentication is verified. This +is usually a `User` or `Customer` datatype. + +With those two items in mind, *servant* provides the following combinator: + +``` haskell ignore +data BasicAuth (realm :: Symbol) (userData :: *) +``` + +You can use this combinator to protect an API as follows: + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Authentication where + +import Control.Monad.Trans.Except (ExceptT, throwE) +import Data.Aeson (ToJSON) +import Data.ByteString (ByteString) +import Data.Map (Map, fromList) +import Data.Monoid ((<>)) +import qualified Data.Map as Map +import Data.Proxy (Proxy (Proxy)) +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.Wai (Request, requestHeaders) +import Network.Wai.Handler.Warp (run) +import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth, + Get, JSON) +import Servant.API.BasicAuth (BasicAuthData (BasicAuthData)) +import Servant.API.Experimental.Auth (AuthProtect) +import Servant.Server (BasicAuthCheck (BasicAuthCheck), + BasicAuthResult( Authorized + , Unauthorized + ), + Context ((:.), EmptyContext), + err401, err403, errBody, Server, + ServantErr, serveWithContext) +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, + mkAuthHandler) +import Servant.Server.Experimental.Auth() + +-- | private data that needs protection +newtype PrivateData = PrivateData { ssshhh :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PrivateData + +-- | public data that anyone can use. +newtype PublicData = PublicData { somedata :: Text } + deriving (Eq, Show, Generic) + +instance ToJSON PublicData + +-- | A user we'll grab from the database when we authenticate someone +newtype User = User { userName :: Text } + deriving (Eq, Show) + +-- | a type to wrap our public api +type PublicAPI = Get '[JSON] [PublicData] + +-- | a type to wrap our private api +type PrivateAPI = Get '[JSON] PrivateData + +-- | our API +type BasicAPI = "public" :> PublicAPI + :<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI + +-- | a value holding a proxy of our API type +basicAuthApi :: Proxy BasicAPI +basicAuthApi = Proxy +``` + +You can see that we've prefixed our public API with "public" and our private +API with "private." Additionally, the private parts of our API use the +`BasicAuth` combinator to protect them under a Basic Authentication scheme (the +realm for this authentication is `"foo-realm"`). + +Unfortunately we're not done. When someone makes a request to our `"private"` +API, we're going to need to provide to servant the logic for validifying +usernames and passwords. This adds a certain conceptual wrinkle in servant's +design that we'll briefly discuss. If you want the **TL;DR**: we supply a lookup +function to servant's new `Context` primitive. + +Until now, all of servant's API combinators extracted information from a request +or dictated the structure of a response (e.g. a `Capture` param is pulled from +the request path). Now consider an API resource protected by basic +authentication. Once the required `WWW-Authenticate` header is checked, we need +to verify the username and password. But how? One solution would be to force an +API author to provide a function of type `BasicAuthData -> ExceptT ServantErr IO User` +and servant should use this function to authenticate a request. Unfortunately +this didn't work prior to `0.5` because all of servant's machinery was +engineered around the idea that each combinator can extract information from +only the request. We cannot extract the function +`BasicAuthData -> ExceptT ServantErr IO User` from a request! Are we doomed? + +Servant `0.5` introduced `Context` to handle this. The type machinery is beyond +the scope of this tutorial, but the idea is simple: provide some data to the +`serve` function, and that data is propagated to the functions that handle each +combinator. Using `Context`, we can supply a function of type +`BasicAuthData -> ExceptT ServantErr IO User` to the `BasicAuth` combinator +handler. This will allow the handler to check authentication and return a `User` +to downstream handlers if successful. + +In practice we wrap `BasicAuthData -> ExceptT ServantErr IO` into a slightly +different function to better capture the semantics of basic authentication: + +``` haskell ignore +-- | The result of authentication/authorization +data BasicAuthResult usr + = Unauthorized + | BadPassword + | NoSuchUser + | Authorized usr + deriving (Eq, Show, Read, Generic, Typeable, Functor) + +-- | Datatype wrapping a function used to check authentication. +newtype BasicAuthCheck usr = BasicAuthCheck + { unBasicAuthCheck :: BasicAuthData + -> IO (BasicAuthResult usr) + } + deriving (Generic, Typeable, Functor) +``` + +We now use this datatype to supply servant with a method to authenticate +requests. In this simple example the only valid username and password is +`"servant"` and `"server"`, respectively, but in a real, production application +you might do some database lookup here. + +```haskell +-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. +authCheck :: BasicAuthCheck User +authCheck = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized (User "servant")) + else return Unauthorized + in BasicAuthCheck check +``` + +And now we create the `Context` used by servant to find `BasicAuthCheck`: + +```haskell +-- | We need to supply our handlers with the right Context. In this case, +-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value +-- tagged with "foo-tag" This context is then supplied to 'server' and threaded +-- to the BasicAuth HasServer handlers. +basicAuthServerContext :: Context (BasicAuthCheck User ': '[]) +basicAuthServerContext = authCheck :. EmptyContext +``` + +We're now ready to write our `server` method that will tie everything together: + +```haskell +-- | an implementation of our server. Here is where we pass all the handlers to our endpoints. +-- In particular, for the BasicAuth protected handler, we need to supply a function +-- that takes 'User' as an argument. +basicAuthServer :: Server BasicAPI +basicAuthServer = + let publicAPIHandler = return [PublicData "foo", PublicData "bar"] + privateAPIHandler (user :: User) = return (PrivateData (userName user)) + in publicAPIHandler :<|> privateAPIHandler +``` + +Finally, our main method and a sample session working with our server: + +```haskell +-- | hello, server! +basicAuthMain :: IO () +basicAuthMain = run 8080 (serveWithContext basicAuthApi + basicAuthServerContext + basicAuthServer + ) + +{- Sample session + +$ curl -XGET localhost:8080/public +[{"somedata":"foo"},{"somedata":"bar"} + +$ curl -iXGET localhost:8080/private +HTTP/1.1 401 Unauthorized +transfer-encoding: chunked +Date: Thu, 07 Jan 2016 22:36:38 GMT +Server: Warp/3.1.8 +WWW-Authenticate: Basic realm="foo-realm" + +$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI=" +HTTP/1.1 200 OK +transfer-encoding: chunked +Date: Thu, 07 Jan 2016 22:37:58 GMT +Server: Warp/3.1.8 +Content-Type: application/json +{"ssshhh":"servant"} +-} +``` + +## Generalized Authentication + +Sometimes your server's authentication scheme doesn't quite fit with the +standards (or perhaps servant hasn't rolled-out support for that new, fancy +authentication scheme). For such a scenario, servant `0.5` provides easy and +simple experimental support to roll your own authentication. + +Why experimental? We worked on the design for authentication for a long time. We +really struggled to find a nice, type-safe niche in the design space. In fact, +`Context` came out of this work, and while it really fit for schemes like Basic +and JWT, it wasn't enough to fully support something like OAuth or HMAC, which +have flows, roles, and other fancy ceremonies. Further, we weren't sure *how* +people will use auth. + +So, in typical startup fashion, we developed an MVP of 'generalized auth' and +released it in an experimental module, with the hope of getting feedback from you! +So, if you're reading this or using generalized auth support, please give us +your feedback! + +### What is Generalized Authentication? + +**TL;DR**: you throw a tagged `AuthProtect` combinator in front of the endpoints +you want protected and then supply a function `Request -> ExceptT IO ServantErr user` +which we run anytime a request matches a protected endpoint. It precisely solves +the "I just need to protect these endpoints with a function that does some +complicated business logic" and nothing more. Behind the scenes we use a type +family instance (`AuthServerData`) and `Context` to accomplish this. + +### Generalized Authentication in Action + +Let's implement a trivial authentication scheme. We will protect our API by +looking for a cookie named `"servant-auth-cookie"`. This cookie's value will +contain a key from which we can lookup a `User`. + +```haskell +-- | A user type that we "fetch from the database" after +-- performing authentication +newtype Account = Account { unAccount :: Text } + +-- | A (pure) database mapping keys to users. +database :: Map ByteString Account +database = fromList [ ("key1", Account "Anne Briggs") + , ("key2", Account "Bruce Cockburn") + , ("key3", Account "Ghédalia Tazartès") + ] + +-- | A method that, when given a password, will return a Account. +-- This is our bespoke (and bad) authentication logic. +lookupAccount :: ByteString -> ExceptT ServantErr IO Account +lookupAccount key = case Map.lookup key database of + Nothing -> throwE (err403 { errBody = "Invalid Cookie" }) + Just usr -> return usr +``` + +For generalized authentication, servant exposes the `AuthHandler` type, +which is used to wrap the `Request -> ExceptT IO ServantErr user` logic. Let's +create a value of type `AuthHandler Request Account` using the above `lookupAccount` +method: + +```haskell +-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO Account +-- we look for a Cookie and pass the value of the cookie to `lookupAccount`. +authHandler :: AuthHandler Request Account +authHandler = + let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of + Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Just authCookieKey -> lookupAccount authCookieKey + in mkAuthHandler handler +``` + +Let's now protect our API with our new, bespoke authentication scheme. We'll +re-use the endpoints from our Basic Authentication example. + +```haskell +-- | Our API, with auth-protection +type AuthGenAPI = "private" :> AuthProtect "cookie-auth" :> PrivateAPI + :<|> "public" :> PublicAPI + +-- | A value holding our type-level API +genAuthAPI :: Proxy AuthGenAPI +genAuthAPI = Proxy +``` + +Now we need to bring everything together for the server. We have the +`AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these +together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html) +instance that tells the `HasServer` instance that our `Context` will supply a +`Account` (via `AuthHandler Request Account`) and that downstream combinators will +have access to this `Account` value (or an error will be thrown if authentication +fails). + +```haskell + +-- | We need to specify the data returned after authentication +type instance AuthServerData (AuthProtect "cookie-auth") = Account +``` + +Note that we specify the type-level tag `"cookie-auth"` when defining the type +family instance. This allows us to have multiple authentication schemes +protecting a single API. + +We now construct the `Context` for our server, allowing us to instantiate a +value of type `Server AuthGenAPI`, in addition to the server value: + +```haskell +-- | The context that will be made available to request handlers. We supply the +-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance +-- of 'AuthProtect' can extract the handler and run it on the request. +genAuthServerContext :: Context (AuthHandler Request Account ': '[]) +genAuthServerContext = authHandler :. EmptyContext + +-- | Our API, where we provide all the author-supplied handlers for each end +-- point. Note that 'privateDataFunc' is a function that takes 'Account' as an +-- argument. We dont' worry about the authentication instrumentation here, +-- that is taken care of by supplying context +genAuthServer :: Server AuthGenAPI +genAuthServer = + let privateDataFunc (Account name) = + return (PrivateData ("this is a secret: " <> name)) + publicData = return [PublicData "this is a public piece of data"] + in privateDataFunc :<|> publicData +``` + +We're now ready to start our server (and provide a sample session)! + +```haskell +-- | run our server +genAuthMain :: IO () +genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuthServer) + +{- Sample Session: + +$ curl -XGET localhost:8080/private +Missing auth header + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3" +[{"ssshhh":"this is a secret: Ghédalia Tazartès"}] + +$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key" +Invalid Cookie + +$ curl -XGET localhost:8080/public +[{"somedata":"this is a public piece of data"}] +-} +``` + +### Recap + +Creating a generalized, ad-hoc authentication scheme was fairly straight +forward: + +1. use the `AuthProtect` combinator to protect your API. +2. choose a application-specific data type used by your server when +authentication is successful (in our case this was `User`). +3. Create a value of `AuthHandler Request User` which encapsulates the +authentication logic (`Request -> ExceptT IO ServantErr User`). This function +will be executed everytime a request matches a protected route. +4. Provide an instance of the `AuthServerData` type family, specifying your +application-specific data type returned when authentication is successful (in +our case this was `User`). + +Caveats: + +1. The module `Servant.Server.Experimental.Auth` contains an orphan `HasServer` +instance for the `AuthProtect` combinator. You may be get orphan instance +warnings when using this. +2. Generalized authentication requires the `UndecidableInstances` extension. + +## Client-side Authentication + +### Basic Authentication + +As of `0.5`, *servant-client* comes with support for basic authentication! +Endpoints protected by Basic Authentication will require a value of type +`BasicAuthData` to complete the request. + +### Generalized Authentication + +Servant `0.5` also shipped with support for generalized authentication. Similar +to the server-side support, clients need to supply an instance of the +`AuthClientData` type family specifying the datatype the client will use to +marshal an unauthenticated request into an authenticated request. Generally, +this will look like: + +```haskell ignore +-- | The datatype we'll use to authenticate a request. If we were wrapping +-- something like OAuth, this might be a Bearer token. +type instance AuthClientData (AuthProtect "cookie-auth") = String + +-- | A method to authenticate a request +authenticateReq :: String -> Req -> Req +authenticateReq s req = SCR.addHeader "my-bespoke-header" s req +``` + +Now, if the client method for our protected endpoint was `getProtected`, then +we could perform authenticated requests as follows: + +```haskell ignore +-- | one could curry this to make it simpler to work with. +result = runExceptT (getProtected (mkAuthenticateReq "secret" authenticateReq)) +``` diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs new file mode 100644 index 00000000..a40ca7c6 --- /dev/null +++ b/doc/tutorial/Client.lhs @@ -0,0 +1,150 @@ +# Querying an API + +While defining handlers that serve an API has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. Except that we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate a bunch of client-side functions. + +**servant** however has a way to inspect APIs, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurence of `Capture`, `ReqBody`, `QueryParam` +and friends. By *derive*, we mean that there's no code generation involved, the functions are defined just by the structure of the API type. + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeOperators #-} + +module Client where + +import Control.Monad.Trans.Except (ExceptT, runExceptT) +import Data.Aeson +import Data.Proxy +import GHC.Generics +import Network.HTTP.Client (Manager, newManager, defaultManagerSettings) +import Servant.API +import Servant.Client +``` + +Also, we need examples for some domain specific data types: + +``` haskell +data Position = Position + { x :: Int + , y :: Int + } deriving (Show, Generic) + +instance FromJSON Position + +newtype HelloMessage = HelloMessage { msg :: String } + deriving (Show, Generic) + +instance FromJSON HelloMessage + +data ClientInfo = ClientInfo + { clientName :: String + , clientEmail :: String + , clientAge :: Int + , clientInterestedIn :: [String] + } deriving Generic + +instance ToJSON ClientInfo + +data Email = Email + { from :: String + , to :: String + , subject :: String + , body :: String + } deriving (Show, Generic) + +instance FromJSON Email +``` + +Enough chitchat, let's see an example. Consider the following API type from the previous section: + +``` haskell +type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position + :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage + :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email +``` + +What we are going to get with **servant-client** here is 3 functions, one to query each endpoint: + +``` haskell +position :: Int -- ^ value for "x" + -> Int -- ^ value for "y" + -> Manager -- ^ the HTTP client to use + -> BaseUrl -- ^ the URL at which the API can be found + -> ExceptT ServantError IO Position + +hello :: Maybe String -- ^ an optional value for "name" + -> Manager -- ^ the HTTP client to use + -> BaseUrl -- ^ the URL at which the API can be found + -> ExceptT ServantError IO HelloMessage + +marketing :: ClientInfo -- ^ value for the request body + -> Manager -- ^ the HTTP client to use + -> BaseUrl -- ^ the URL at which the API can be found + -> ExceptT ServantError IO Email +``` + +Each function makes available as an argument any value that the response may +depend on, as evidenced in the API type. How do we get these functions? By calling +the function `client`. It takes one argument: + +- a `Proxy` to your API, + +``` haskell +api :: Proxy API +api = Proxy + +position :<|> hello :<|> marketing = client api +``` + +As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just: + +``` haskell ignore +-- | URI scheme to use +data Scheme = + Http -- ^ http:// + | Https -- ^ https:// + deriving + +-- | Simple data type to represent the target of HTTP requests +-- for servant's automatically-generated clients. +data BaseUrl = BaseUrl + { baseUrlScheme :: Scheme -- ^ URI scheme to use + , baseUrlHost :: String -- ^ host (eg "haskell.org") + , baseUrlPort :: Int -- ^ port (eg 80) + } +``` + +That's it. Let's now write some code that uses our client functions. + +``` haskell +queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email) +queries manager baseurl = do + pos <- position 10 10 manager baseurl + message <- hello (Just "servant") manager baseurl + em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl + return (pos, message, em) + +run :: IO () +run = do + manager <- newManager defaultManagerSettings + res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 "")) + case res of + Left err -> putStrLn $ "Error: " ++ show err + Right (pos, message, em) -> do + print pos + print message + print em +``` + +Here's the output of the above code running against the appropriate server: + +``` bash +Position {x = 10, y = 10} +HelloMessage {msg = "Hello, servant"} +Email {from = "great@company.com", to = "alp@foo.com", subject = "Hey Alp, we miss you!", body = "Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!"} +``` + +The types of the arguments for the functions are the same as for (server-side) request handlers. You now know how to use **servant-client**! diff --git a/doc/tutorial/Docs.lhs b/doc/tutorial/Docs.lhs new file mode 100644 index 00000000..fa7b0c43 --- /dev/null +++ b/doc/tutorial/Docs.lhs @@ -0,0 +1,234 @@ +# Documenting an API + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Docs where + +import Data.ByteString.Lazy (ByteString) +import Data.Proxy +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Text.Lazy (pack) +import Network.HTTP.Types +import Network.Wai +import Servant.API +import Servant.Docs +import Servant.Server +``` + +And we'll import some things from one of our earlier modules +([Serving an API](Server.html)): + +``` haskell +import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..), + server3, emailForClient) +``` + +Like client function generation, documentation generation amounts to inspecting the API type and extracting all the data we need to then present it in some format to users of your API. + +This time however, we have to assist **servant**. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier: + +``` haskell +type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position + :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage + :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email + +exampleAPI :: Proxy ExampleAPI +exampleAPI = Proxy +``` + +While **servant** can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required. + +For every capture, request body, response body, query param, we have to give some explanations about how it influences the response, what values are possible and the likes. Here's how it looks like for the parameters we have above. + +``` haskell +instance ToCapture (Capture "x" Int) where + toCapture _ = + DocCapture "x" -- name + "(integer) position on the x axis" -- description + +instance ToCapture (Capture "y" Int) where + toCapture _ = + DocCapture "y" -- name + "(integer) position on the y axis" -- description + +instance ToSample Position where + toSamples _ = singleSample (Position 3 14) -- example of output + +instance ToParam (QueryParam "name" String) where + toParam _ = + DocQueryParam "name" -- name + ["Alp", "John Doe", "..."] -- example of values (not necessarily exhaustive) + "Name of the person to say hello to." -- description + Normal -- Normal, List or Flag + +instance ToSample HelloMessage where + toSamples _ = + [ ("When a value is provided for 'name'", HelloMessage "Hello, Alp") + , ("When 'name' is not specified", HelloMessage "Hello, anonymous coward") + ] + -- mutliple examples to display this time + +ci :: ClientInfo +ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] + +instance ToSample ClientInfo where + toSamples _ = singleSample ci + +instance ToSample Email where + toSamples _ = singleSample (emailForClient ci) +``` + +Types that are used as request or response bodies have to instantiate the `ToSample` typeclass which lets you specify one or more examples of values. `Capture`s and `QueryParam`s have to instantiate their respective `ToCapture` and `ToParam` classes and provide a name and some information about the concrete meaning of that argument, as illustrated in the code above. + +With all of this, we can derive docs for our API. + +``` haskell +apiDocs :: API +apiDocs = docs exampleAPI +``` + +`API` is a type provided by **servant-docs** that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, **servant-docs** only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [**servant-pandoc**](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats. + +**servant**'s markdown pretty printer is a function named `markdown`. + +``` haskell ignore +markdown :: API -> String +``` + +That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`. + +````````` text +## Welcome + +This is our super webservice's API. + +Enjoy! + +## GET /hello + +#### GET Parameters: + +- name + - **Values**: *Alp, John Doe, ...* + - **Description**: Name of the person to say hello to. + + +#### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json` + +- When a value is provided for 'name' + + ```javascript + {"msg":"Hello, Alp"} + ``` + +- When 'name' is not specified + + ```javascript + {"msg":"Hello, anonymous coward"} + ``` + +## POST /marketing + +#### Request: + +- Supported content types are: + + - `application/json` + +- Example: `application/json` + + ```javascript + {"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"} + ``` + +#### Response: + +- Status code 201 +- Headers: [] + +- Supported content types are: + + - `application/json` + +- Response body as below. + + ```javascript + {"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} + ``` + +## GET /position/:x/:y + +#### Captures: + +- *x*: (integer) position on the x axis +- *y*: (integer) position on the y axis + +#### Response: + +- Status code 200 +- Headers: [] + +- Supported content types are: + + - `application/json` + +- Response body as below. + + ```javascript + {"x":3,"y":14} + ``` + +````````` + +However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what **wai** expects for `Raw` endpoints. + +``` haskell +docsBS :: ByteString +docsBS = encodeUtf8 + . pack + . markdown + $ docsWithIntros [intro] exampleAPI + + where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"] +``` + +`docsWithIntros` just takes an additional parameter, a list of `DocIntro`s that must be displayed before any endpoint docs. + +We can now serve the API *and* the API docs with a simple server. + +``` haskell +type DocsAPI = ExampleAPI :<|> Raw + +api :: Proxy DocsAPI +api = Proxy + +server :: Server DocsAPI +server = Server.server3 :<|> serveDocs + + where serveDocs _ respond = + respond $ responseLBS ok200 [plain] docsBS + + plain = ("Content-Type", "text/plain") + +app :: Application +app = serve api server +``` + +And if you spin up this server and request anything else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type. diff --git a/doc/tutorial/Javascript.lhs b/doc/tutorial/Javascript.lhs new file mode 100644 index 00000000..4054e4b3 --- /dev/null +++ b/doc/tutorial/Javascript.lhs @@ -0,0 +1,228 @@ +# Generating Javascript functions to query an API + +We will now see how **servant** lets you turn an API type into javascript +functions that you can call to query a webservice. + +For this, we will consider a simple page divided in two parts. At the top, we +will have a search box that lets us search in a list of Haskell books by +author/title with a list of results that gets updated every time we enter or +remove a character, while at the bottom we will be able to see the classical +[probabilistic method to approximate +pi](http://en.wikipedia.org/wiki/Approximations_of_%CF%80#Summing_a_circle.27s_area), +using a webservice to get random points. Finally, we will serve an HTML file +along with a couple of Javascript files, among which one that's automatically +generated from the API type and which will provide ready-to-use functions to +query your API. + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Javascript where + +import Control.Monad.IO.Class +import Data.Aeson +import Data.Proxy +import Data.Text as T (Text) +import Data.Text.IO as T (writeFile, readFile) +import GHC.Generics +import Language.Javascript.JQuery +import Network.Wai +import Network.Wai.Handler.Warp +import qualified Data.Text as T +import Servant +import Servant.JS +import System.Random +``` + +Now let's have the API type(s) and the accompanying datatypes. + +``` haskell +type API = "point" :> Get '[JSON] Point + :<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book) + +type API' = API :<|> Raw + +data Point = Point + { x :: Double + , y :: Double + } deriving Generic + +instance ToJSON Point + +data Search a = Search + { query :: Text + , results :: [a] + } deriving Generic + +mkSearch :: Text -> [a] -> Search a +mkSearch = Search + +instance ToJSON a => ToJSON (Search a) + +data Book = Book + { author :: Text + , title :: Text + , year :: Int + } deriving Generic + +instance ToJSON Book + +book :: Text -> Text -> Int -> Book +book = Book +``` + +We need a "book database". For the purpose of this guide, let's restrict +ourselves to the following books. + +``` haskell +books :: [Book] +books = + [ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000 + , book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008 + , book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011 + , book "Graham Hutton" "Programming in Haskell" 2007 + , book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013 + , book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998 + ] +``` + +Now, given an optional search string `q`, we want to perform a case insensitive +search in that list of books. We're obviously not going to try and implement +the best possible algorithm, this is out of scope for this tutorial. The +following simple linear scan will do, given how small our list is. + +``` haskell +searchBook :: Monad m => Maybe Text -> m (Search Book) +searchBook Nothing = return (mkSearch "" books) +searchBook (Just q) = return (mkSearch q books') + + where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b) + || q' `T.isInfixOf` T.toLower (title b) + ) + books + q' = T.toLower q +``` + +We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y +<= 1`. The code below uses +[random](http://hackage.haskell.org/package/random)'s `System.Random`. + +``` haskell +randomPoint :: MonadIO m => m Point +randomPoint = liftIO . getStdRandom $ \g -> + let (rx, g') = randomR (-1, 1) g + (ry, g'') = randomR (-1, 1) g' + in (Point rx ry, g'') +``` + +If we add static file serving, our server is now complete. + +``` haskell +api :: Proxy API +api = Proxy + +api' :: Proxy API' +api' = Proxy + +server :: Server API +server = randomPoint + :<|> searchBook + +server' :: Server API' +server' = server + :<|> serveDirectory "static" + +app :: Application +app = serve api' server' + +main :: IO () +main = run 8000 app +``` + +Why two different API types, proxies and servers though? Simply because we +don't want to generate javascript functions for the `Raw` part of our API type, +so we need a `Proxy` for our API type `API'` without its `Raw` endpoint. + +Very similarly to how one can derive haskell functions, we can derive the +javascript with just a simple function call to `jsForAPI` from +`Servant.JQuery`. + +``` haskell +apiJS :: Text +apiJS = jsForAPI api vanillaJS +``` + +This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks': + +``` javascript +var getPoint = function(onSuccess, onError) +{ + var xhr = new XMLHttpRequest(); + xhr.open('GET', '/point', true); + xhr.setRequestHeader("Accept","application/json"); + xhr.onreadystatechange = function (e) { + if (xhr.readyState == 4) { + if (xhr.status == 204 || xhr.status == 205) { + onSuccess(); + } else if (xhr.status >= 200 && xhr.status < 300) { + var value = JSON.parse(xhr.responseText); + onSuccess(value); + } else { + var value = JSON.parse(xhr.responseText); + onError(value); + } + } + } + xhr.send(null); +} + +var getBooks = function(q, onSuccess, onError) +{ + var xhr = new XMLHttpRequest(); + xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true); + xhr.setRequestHeader("Accept","application/json"); + xhr.onreadystatechange = function (e) { + if (xhr.readyState == 4) { + if (xhr.status == 204 || xhr.status == 205) { + onSuccess(); + } else if (xhr.status >= 200 && xhr.status < 300) { + var value = JSON.parse(xhr.responseText); + onSuccess(value); + } else { + var value = JSON.parse(xhr.responseText); + onError(value); + } + } + } + xhr.send(null); +} +``` + +We created a directory `static` that contains two static files: `index.html`, +which is the entrypoint to our little web application; and `ui.js`, which +contains some hand-written javascript. This javascript code assumes the two +generated functions `getPoint` and `getBooks` in scope. Therefore we need to +write the generated javascript into a file: + +``` haskell +writeJSFiles :: IO () +writeJSFiles = do + T.writeFile "static/api.js" apiJS + jq <- T.readFile =<< Language.Javascript.JQuery.file + T.writeFile "static/jq.js" jq +``` + +(We're also writing the jquery library into a file, as it's also used by +`ui.js`.) `static/api.js` will be included in `index.html` and the two +generated functions will therefore be available in `ui.js`. + +And we're good to go. You can start the `main` function of this file and go to +`http://localhost:8000/`. Start typing in the name of one of the authors in our +database or part of a book title, and check out how long it takes to +approximate pi using the method mentioned above. diff --git a/servant-examples/LICENSE b/doc/tutorial/LICENSE similarity index 92% rename from servant-examples/LICENSE rename to doc/tutorial/LICENSE index f2e47b91..fc4415bd 100644 --- a/servant-examples/LICENSE +++ b/doc/tutorial/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Alp Mestanogullari +Copyright (c) 2016, Servant Contributors All rights reserved. @@ -13,7 +13,7 @@ modification, are permitted provided that the following conditions are met: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Alp Mestanogullari nor the names of other + * Neither the name of Servant Contributors nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs new file mode 100644 index 00000000..bd84b8a0 --- /dev/null +++ b/doc/tutorial/Server.lhs @@ -0,0 +1,1115 @@ +# Serving an API + +Enough chit-chat about type-level combinators and representing an API as a +type. Can we have a webservice already? + +## A first example + +Equipped with some basic knowledge about the way we represent APIs, let's now +write our first webservice. + +The source for this tutorial section is a literate haskell file, so first we +need to have some language extensions and imports: + +``` haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Server where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Except +import Control.Monad.Reader +import Data.Aeson.Compat +import Data.Aeson.Types +import Data.Attoparsec.ByteString +import Data.ByteString (ByteString) +import Data.List +import Data.Maybe +import Data.String.Conversions +import Data.Time.Calendar +import GHC.Generics +import Lucid +import Network.HTTP.Media ((//), (/:)) +import Network.Wai +import Network.Wai.Handler.Warp +import Servant +import System.Directory +import Text.Blaze +import Text.Blaze.Html.Renderer.Utf8 +import qualified Data.Aeson.Parser +import qualified Text.Blaze.Html +``` + +**Important**: the `Servant` module comes from the **servant-server** package, +the one that lets us run webservers that implement a particular API type. It +reexports all the types from the **servant** package that let you declare API +types as well as everything you need to turn your request handlers into a +fully-fledged webserver. This means that in your applications, you can just add +**servant-server** as a dependency, import `Servant` and not worry about anything +else. + +We will write a server that will serve the following API. + +``` haskell +type UserAPI1 = "users" :> Get '[JSON] [User] +``` + +Here's what we would like to see when making a GET request to `/users`. + +``` javascript +[ {"name": "Isaac Newton", "age": 372, "email": "isaac@newton.co.uk", "registration_date": "1683-03-01"} +, {"name": "Albert Einstein", "age": 136, "email": "ae@mc2.org", "registration_date": "1905-12-01"} +] +``` + +Now let's define our `User` data type and write some instances for it. + +``` haskell +data User = User + { name :: String + , age :: Int + , email :: String + , registration_date :: Day + } deriving (Eq, Show, Generic) + +instance ToJSON User +``` + +Nothing funny going on here. But we now can define our list of two users. + +``` haskell +users1 :: [User] +users1 = + [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) + , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) + ] +``` + +Let's also write our API type. + +``` haskell ignore +type UserAPI1 = "users" :> Get '[JSON] [User] +``` + +We can now take care of writing the actual webservice that will handle requests +to such an API. This one will be very simple, being reduced to just a single +endpoint. The type of the web application is determined by the API type, +through a *type family* named `Server`. (Type families are just functions that +take types as input and return types.) The `Server` type family will compute +the right type that a bunch of request handlers should have just from the +corresponding API type. + +The first thing to know about the `Server` type family is that behind the +scenes it will drive the routing, letting you focus only on the business +logic. The second thing to know is that for each endpoint, your handlers will +by default run in the `ExceptT ServantErr IO` monad. This is overridable very +easily, as explained near the end of this guide. Third thing, the type of the +value returned in that monad must be the same as the second argument of the +HTTP method combinator used for the corresponding endpoint. In our case, it +means we must provide a handler of type `ExceptT ServantErr IO [User]`. Well, +we have a monad, let's just `return` our list: + +``` haskell +server1 :: Server UserAPI1 +server1 = return users1 +``` + +That's it. Now we can turn `server` into an actual webserver using +[wai](http://hackage.haskell.org/package/wai) and +[warp](http://hackage.haskell.org/package/warp): + +``` haskell +userAPI :: Proxy UserAPI1 +userAPI = Proxy + +-- 'serve' comes from servant and hands you a WAI Application, +-- which you can think of as an "abstract" web application, +-- not yet a webserver. +app1 :: Application +app1 = serve userAPI server1 +``` + +The `userAPI` bit is, alas, boilerplate (we need it to guide type inference). +But that's about as much boilerplate as you get. + +And we're done! Let's run our webservice on the port 8081. + +``` haskell +main :: IO () +main = run 8081 app1 +``` + +You can put this all into a file or just grab [servant's +repo](http://github.com/haskell-servant/servant) and look at the +*doc/tutorial* directory. This code (the source of this web page) is in +*doc/tutorial/Server.lhs*. + +If you run it, you can go to `http://localhost:8081/users` in your browser or +query it with curl and you see: + +``` bash +$ curl http://localhost:8081/users +[{"email":"isaac@newton.co.uk","registration_date":"1683-03-01","age":372,"name":"Isaac Newton"},{"email":"ae@mc2.org","registration_date":"1905-12-01","age":136,"name":"Albert Einstein"}] +``` + +## More endpoints + +What if we want more than one endpoint? Let's add `/albert` and `/isaac` to +view the corresponding users encoded in JSON. + +``` haskell +type UserAPI2 = "users" :> Get '[JSON] [User] + :<|> "albert" :> Get '[JSON] User + :<|> "isaac" :> Get '[JSON] User +``` + +And let's adapt our code a bit. + +``` haskell +isaac :: User +isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) + +albert :: User +albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) + +users2 :: [User] +users2 = [isaac, albert] +``` + +Now, just like we separate the various endpoints in `UserAPI` with `:<|>`, we +are going to separate the handlers with `:<|>` too! They must be provided in +the same order as in in the API type. + +``` haskell +server2 :: Server UserAPI2 +server2 = return users2 + :<|> return albert + :<|> return isaac +``` + +And that's it! You can run this example in the same way that we showed for +`server1` and check out the data available at `/users`, `/albert` and `/isaac`. + +## From combinators to handler arguments + +Fine, we can write trivial webservices easily, but none of the two above use +any "fancy" combinator from servant. Let's address this and use `QueryParam`, +`Capture` and `ReqBody` right away. You'll see how each occurence of these +combinators in an endpoint makes the corresponding handler receive an +argument of the appropriate type automatically. You don't have to worry about +manually looking up URL captures or query string parameters, or +decoding/encoding data from/to JSON. Never. + +We are going to use the following data types and functions to implement a +server for `API`. + +``` haskell +type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position + :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage + :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email + +data Position = Position + { xCoord :: Int + , yCoord :: Int + } deriving Generic + +instance ToJSON Position + +newtype HelloMessage = HelloMessage { msg :: String } + deriving Generic + +instance ToJSON HelloMessage + +data ClientInfo = ClientInfo + { clientName :: String + , clientEmail :: String + , clientAge :: Int + , clientInterestedIn :: [String] + } deriving Generic + +instance FromJSON ClientInfo +instance ToJSON ClientInfo + +data Email = Email + { from :: String + , to :: String + , subject :: String + , body :: String + } deriving Generic + +instance ToJSON Email + +emailForClient :: ClientInfo -> Email +emailForClient c = Email from' to' subject' body' + + where from' = "great@company.com" + to' = clientEmail c + subject' = "Hey " ++ clientName c ++ ", we miss you!" + body' = "Hi " ++ clientName c ++ ",\n\n" + ++ "Since you've recently turned " ++ show (clientAge c) + ++ ", have you checked out our latest " + ++ intercalate ", " (clientInterestedIn c) + ++ " products? Give us a visit!" +``` + +We can implement handlers for the three endpoints: + +``` haskell +server3 :: Server API +server3 = position + :<|> hello + :<|> marketing + + where position :: Int -> Int -> ExceptT ServantErr IO Position + position x y = return (Position x y) + + hello :: Maybe String -> ExceptT ServantErr IO HelloMessage + hello mname = return . HelloMessage $ case mname of + Nothing -> "Hello, anonymous coward" + Just n -> "Hello, " ++ n + + marketing :: ClientInfo -> ExceptT ServantErr IO Email + marketing clientinfo = return (emailForClient clientinfo) +``` + +Did you see that? The types for your handlers changed to be just what we +needed! In particular: + + - a `Capture "something" a` becomes an argument of type `a` (for `position`); + - a `QueryParam "something" a` becomes an argument of type `Maybe a` (because +an endpoint can technically be accessed without specifying any query +string parameter, we decided to "force" handlers to be aware that the +parameter might not always be there); + + - a `ReqBody contentTypeList a` becomes an argument of type `a`; + +And that's it. Here's the example in action: + +``` bash +$ curl http://localhost:8081/position/1/2 +{"xCoord":1,"yCoord":2} +$ curl http://localhost:8081/hello +{"msg":"Hello, anonymous coward"} +$ curl http://localhost:8081/hello?name=Alp +{"msg":"Hello, Alp"} +$ curl -X POST -d '{"clientName":"Alp Mestanogullari", "clientEmail" : "alp@foo.com", "clientAge": 25, "clientInterestedIn": ["haskell", "mathematics"]}' -H 'Accept: application/json' -H 'Content-type: application/json' http://localhost:8081/marketing +{"subject":"Hey Alp Mestanogullari, we miss you!","body":"Hi Alp Mestanogullari,\n\nSince you've recently turned 25, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"} +``` + +For reference, here's a list of some combinators from **servant**: + + > - `Delete`, `Get`, `Patch`, `Post`, `Put`: these do not become arguments. They provide the return type of handlers, which usually is `ExceptT ServantErr IO `. + > - `Capture "something" a` becomes an argument of type `a`. + > - `QueryParam "something" a`, `Header "something" a` all become arguments of type `Maybe a`, because there might be no value at all specified by the client for these. + > - `QueryFlag "something"` gets turned into an argument of type `Bool`. + > - `QueryParams "something" a` gets turned into an argument of type `[a]`. + > - `ReqBody contentTypes a` gets turned into an argument of type `a`. + +## The `FromHttpApiData`/`ToHttpApiData` classes + +Wait... How does **servant** know how to decode the `Int`s from the URL? Or how +to decode a `ClientInfo` value from the request body? This is what this and the +following two sections address. + +`Capture`s and `QueryParam`s are represented by some textual value in URLs. +`Header`s are similarly represented by a pair of a header name and a +corresponding (textual) value in the request's "metadata". How types are +decoded from headers, captures, and query params is expressed in a class +`FromHttpApiData` (from the package +[**http-api-data**](http://hackage.haskell.org/package/http-api-data)): + +``` haskell ignore +class FromHttpApiData a where + {-# MINIMAL parseUrlPiece | parseQueryParam #-} + -- | Parse URL path piece. + parseUrlPiece :: Text -> Either Text a + parseUrlPiece = parseQueryParam + + -- | Parse HTTP header value. + parseHeader :: ByteString -> Either Text a + parseHeader = parseUrlPiece . decodeUtf8 + + -- | Parse query param value. + parseQueryParam :: Text -> Either Text a + parseQueryParam = parseUrlPiece +``` + +As you can see, as long as you provide either `parseUrlPiece` (for `Capture`s) +or `parseQueryParam` (for `QueryParam`s), the other methods will be defined in +terms of this. + +**http-api-data** provides a decent number of instances, helpers for defining new +ones, and wonderful documentation. + +There's not much else to say about these classes. You will need instances for +them when using `Capture`, `QueryParam`, `QueryParams`, and `Header` with your +types. You will need `FromHttpApiData` instances for server-side request +handlers and `ToHttpApiData` instances only when using +**servant-client**, as described in the [section about deriving haskell +functions to query an API](Client.html). + +## Using content-types with your data types + +The same principle was operating when decoding request bodies from JSON, and +responses *into* JSON. (JSON is just the running example - you can do this with +any content-type.) + +This section introduces a couple of typeclasses provided by **servant** that make +all of this work. + +### The truth behind `JSON` + + +What exactly is `JSON` (the type as used in `Get '[JSON] User`)? Like the 3 +other content-types provided out of the box by **servant**, it's a really dumb +data type. + +``` haskell ignore +data JSON +data PlainText +data FormUrlEncoded +data OctetStream +``` + +Obviously, this is not all there is to `JSON`, otherwise it would be quite +pointless. Like most of the data types in **servant**, `JSON` is mostly there as +a special *symbol* that's associated with encoding (resp. decoding) to (resp. +from) the *JSON* format. The way this association is performed can be +decomposed into two steps. + +The first step is to provide a proper +`MediaType` (from +[**http-media**](https://hackage.haskell.org/package/http-media-0.6.2/docs/Network-HTTP-Media.html)) +representation for `JSON`, or for your own content-types. If you look at the +haddocks from this link, you can see that we just have to specify +`application/json` using the appropriate functions. In our case, we can just +use `(//) :: ByteString -> ByteString -> MediaType`. The precise way to specify +the `MediaType` is to write an instance for the `Accept` class: + +``` haskell ignore +-- for reference: +class Accept ctype where + contentType :: Proxy ctype -> MediaType + +instance Accept JSON where + contentType _ = "application" // "json" +``` + +The second step is centered around the `MimeRender` and `MimeUnrender` classes. +These classes just let you specify a way to encode and decode +values into or from your content-type's representation. + +``` haskell ignore +class Accept ctype => MimeRender ctype a where + mimeRender :: Proxy ctype -> a -> ByteString + -- alternatively readable as: + mimeRender :: Proxy ctype -> (a -> ByteString) +``` + +Given a content-type and some user type, `MimeRender` provides a function that +encodes values of type `a` to lazy `ByteString`s. + +In the case of `JSON`, this is easily dealt with! For any type `a` with a +`ToJSON` instance, we can render values of that type to JSON using +`Data.Aeson.encode`. + +``` haskell ignore +instance ToJSON a => MimeRender JSON a where + mimeRender _ = encode +``` + +And now the `MimeUnrender` class, which lets us extract values from lazy +`ByteString`s, alternatively failing with an error string. + +``` haskell ignore +class Accept ctype => MimeUnrender ctype a where + mimeUnrender :: Proxy ctype -> ByteString -> Either String a +``` + +We don't have much work to do there either, `Data.Aeson.eitherDecode` is +precisely what we need. However, it only allows arrays and objects as toplevel +JSON values and this has proven to get in our way more than help us so we wrote +our own little function around **aeson** and **attoparsec** that allows any type of +JSON value at the toplevel of a "JSON document". Here's the definition in case +you are curious. + +``` haskell +eitherDecodeLenient :: FromJSON a => ByteString -> Either String a +eitherDecodeLenient input = do + v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input) + parseEither parseJSON v +``` + +This function is exactly what we need for our `MimeUnrender` instance. + +``` haskell ignore +instance FromJSON a => MimeUnrender JSON a where + mimeUnrender _ = eitherDecodeLenient +``` + +And this is all the code that lets you use `JSON` with `ReqBody`, `Get`, +`Post` and friends. We can check our understanding by implementing support +for an `HTML` content-type, so that users of your webservice can access an +HTML representation of the data they want, ready to be included in any HTML +document, e.g. using [jQuery's `load` function](https://api.jquery.com/load/), +simply by adding `Accept: text/html` to their request headers. + +### Case-studies: **servant-blaze** and **servant-lucid** + +These days, most of the haskellers who write their HTML UIs directly from +Haskell use either [**blaze-html**](http://hackage.haskell.org/package/blaze-html) +or [**lucid**](http://hackage.haskell.org/package/lucid). The best option for +**servant** is obviously to support both (and hopefully other templating +solutions!). We're first going to look at **lucid**: + +``` haskell +data HTMLLucid +``` + +Once again, the data type is just there as a symbol for the encoding/decoding +functions, except that this time we will only worry about encoding since +**lucid** doesn't provide a way to extract data from HTML. + +``` haskell +instance Accept HTMLLucid where + contentType _ = "text" // "html" /: ("charset", "utf-8") +``` + +Note that this instance uses the `(/:)` operator from **http-media** which lets +us specify additional information about a content-type, like the charset here. + +The rendering instances call similar functions that take +types with an appropriate instance to an "abstract" HTML representation and +then write that to a `ByteString`. + +``` haskell +instance ToHtml a => MimeRender HTMLLucid a where + mimeRender _ = renderBS . toHtml + +-- let's also provide an instance for lucid's +-- 'Html' wrapper. +instance MimeRender HTMLLucid (Html a) where + mimeRender _ = renderBS +``` + +For **blaze-html** everything works very similarly: + +``` haskell +-- For this tutorial to compile 'HTMLLucid' and 'HTMLBlaze' have to be +-- distinct. Usually you would stick to one html rendering library and then +-- you can go with one 'HTML' type. +data HTMLBlaze + +instance Accept HTMLBlaze where + contentType _ = "text" // "html" /: ("charset", "utf-8") + +instance ToMarkup a => MimeRender HTMLBlaze a where + mimeRender _ = renderHtml . Text.Blaze.Html.toHtml + +-- while we're at it, just like for lucid we can +-- provide an instance for rendering blaze's 'Html' type +instance MimeRender HTMLBlaze Text.Blaze.Html.Html where + mimeRender _ = renderHtml +``` + +Both [**servant-blaze**](http://hackage.haskell.org/package/servant-blaze) and +[**servant-lucid**](http://hackage.haskell.org/package/servant-lucid) let you use +`HTMLLucid` and `HTMLBlaze` in any content-type list as long as you provide an instance of the +appropriate class (`ToMarkup` for **blaze-html**, `ToHtml` for **lucid**). + +We can now write a webservice that uses **servant-lucid** to show the `HTMLLucid` +content-type in action. We will be serving the following API: + +``` haskell +type PersonAPI = "persons" :> Get '[JSON, HTMLLucid] [Person] +``` + +where `Person` is defined as follows: + +``` haskell +data Person = Person + { firstName :: String + , lastName :: String + } deriving Generic -- for the JSON instance + +instance ToJSON Person +``` + +Now, let's teach **lucid** how to render a `Person` as a row in a table, and then +a list of `Person`s as a table with a row per person. + +``` haskell +-- HTML serialization of a single person +instance ToHtml Person where + toHtml person = + tr_ $ do + td_ (toHtml $ firstName person) + td_ (toHtml $ lastName person) + + -- do not worry too much about this + toHtmlRaw = toHtml + +-- HTML serialization of a list of persons +instance ToHtml [Person] where + toHtml persons = table_ $ do + tr_ $ do + th_ "first name" + th_ "last name" + + -- this just calls toHtml on each person of the list + -- and concatenates the resulting pieces of HTML together + foldMap toHtml persons + + toHtmlRaw = toHtml +``` + +We create some `Person` values and serve them as a list: + +``` haskell +people :: [Person] +people = + [ Person "Isaac" "Newton" + , Person "Albert" "Einstein" + ] + +personAPI :: Proxy PersonAPI +personAPI = Proxy + +server4 :: Server PersonAPI +server4 = return people + +app2 :: Application +app2 = serve personAPI server4 +``` + +And we're good to go: + +``` bash +$ curl http://localhost:8081/persons +[{"lastName":"Newton","firstName":"Isaac"},{"lastName":"Einstein","firstName":"Albert"}] +$ curl -H 'Accept: text/html' http://localhost:8081/persons +
first namelast name
IsaacNewton
AlbertEinstein
+# or just point your browser to http://localhost:8081/persons +``` + +## The `ExceptT ServantErr IO` monad + +At the heart of the handlers is the monad they run in, namely `ExceptT +ServantErr IO` +([haddock documentation for `ExceptT`](http://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT)). +One might wonder: why this monad? The answer is that it is the +simplest monad with the following properties: + +- it lets us both return a successful result (using `return`) +or "fail" with a descriptive error (using `throwError`); +- it lets us perform IO, which is absolutely vital since most webservices exist +as interfaces to databases that we interact with in `IO`. + +Let's recall some definitions. + +``` haskell ignore +-- from the 'mtl' package at +newtype ExceptT e m a = ExceptT (m (Either e a)) +``` + +In short, this means that a handler of type `ExceptT ServantErr IO a` is simply +equivalent to a computation of type `IO (Either ServantErr a)`, that is, an IO +action that either returns an error or a result. + +The module [`Control.Monad.Except`](https://hackage.haskell.org/package/mtl-2.2.1/docs/Control-Monad-Except.html#t:ExceptT) +from which `ExceptT` comes is worth looking at. +Perhaps most importantly, `ExceptT` is an instance of `MonadError`, so +`throwError` can be used to return an error from your handler (whereas `return` + is enough to return a success). + +Most of what you'll be doing in your handlers is running some IO and, +depending on the result, you might sometimes want to throw an error of some +kind and abort early. The next two sections cover how to do just that. + +### Performing IO + +Another important instance from the list above is `MonadIO m => MonadIO +(ExceptT e m)`. +[`MonadIO`](http://hackage.haskell.org/package/transformers-0.4.3.0/docs/Control-Monad-IO-Class.html) +is a class from the **transformers** package defined as: + +``` haskell ignore +class Monad m => MonadIO m where + liftIO :: IO a -> m a +``` + +The `IO` monad provides a `MonadIO` instance. Hence for any type +`e`, `ExceptT e IO` has a `MonadIO` instance. So if you want to run any kind of +IO computation in your handlers, just use `liftIO`: + +``` haskell +type IOAPI1 = "myfile.txt" :> Get '[JSON] FileContent + +newtype FileContent = FileContent + { content :: String } + deriving Generic + +instance ToJSON FileContent + +server5 :: Server IOAPI1 +server5 = do + filecontent <- liftIO (readFile "myfile.txt") + return (FileContent filecontent) +``` + +### Failing, through `ServantErr` + +If you want to explicitly fail at providing the result promised by an endpoint +using the appropriate HTTP status code (not found, unauthorized, etc) and some +error message, all you have to do is use the `throwError` function mentioned above +and provide it with the appropriate value of type `ServantErr`, which is +defined as: + +``` haskell ignore +data ServantErr = ServantErr + { errHTTPCode :: Int + , errReasonPhrase :: String + , errBody :: ByteString -- lazy bytestring + , errHeaders :: [Header] + } +``` + +Many standard values are provided out of the box by the `Servant.Server` +module. If you want to use these values but add a body or some headers, just +use record update syntax: + +``` haskell +failingHandler :: ExceptT ServantErr IO () +failingHandler = throwError myerr + + where myerr :: ServantErr + myerr = err503 { errBody = "Sorry dear user." } +``` + +Here's an example where we return a customised 404-Not-Found error message in +the response body if "myfile.txt" isn't there: + +``` haskell +server6 :: Server IOAPI1 +server6 = do + exists <- liftIO (doesFileExist "myfile.txt") + if exists + then liftIO (readFile "myfile.txt") >>= return . FileContent + else throwError custom404Err + + where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } +``` + +Here's how that server looks in action: + +``` bash +$ curl --verbose http://localhost:8081/myfile.txt +[snip] +* Connected to localhost (127.0.0.1) port 8081 (#0) +> GET /myfile.txt HTTP/1.1 +> User-Agent: curl/7.30.0 +> Host: localhost:8081 +> Accept: */* +> +< HTTP/1.1 404 Not Found +[snip] +myfile.txt just isnt there, please leave this server alone. + +$ echo Hello > myfile.txt + +$ curl --verbose http://localhost:8081/myfile.txt +[snip] +* Connected to localhost (127.0.0.1) port 8081 (#0) +> GET /myfile.txt HTTP/1.1 +> User-Agent: curl/7.30.0 +> Host: localhost:8081 +> Accept: */* +> +< HTTP/1.1 200 OK +[snip] +< Content-Type: application/json +[snip] +{"content":"Hello\n"} +``` + +## Response headers + +To add headers to your response, use +[addHeader](http://hackage.haskell.org/package/servant/docs/Servant-API-ResponseHeaders.html). +Note that this changes the type of your API, as we can see in the following example: + +``` haskell +type MyHandler = Get '[JSON] (Headers '[Header "X-An-Int" Int] User) + +myHandler :: Server MyHandler +myHandler = return $ addHeader 1797 albert +``` + +Note that the type of `addHeader x` is different than the type of `x`! + +## Serving static files + +**servant-server** also provides a way to just serve the content of a directory +under some path in your web API. As mentioned earlier in this document, the +`Raw` combinator can be used in your APIs to mean "plug here any WAI +application". Well, **servant-server** provides a function to get a file and +directory serving WAI application, namely: + +``` haskell ignore +-- exported by Servant and Servant.Server +serveDirectory :: FilePath -> Server Raw +``` + +`serveDirectory`'s argument must be a path to a valid directory. + +Here's an example API that will serve some static files: + +``` haskell +type StaticAPI = "static" :> Raw +``` + +And the server: + +``` haskell +staticAPI :: Proxy StaticAPI +staticAPI = Proxy +``` + +``` haskell +server7 :: Server StaticAPI +server7 = serveDirectory "static-files" + +app3 :: Application +app3 = serve staticAPI server7 +``` + +This server will match any request whose path starts with `/static` and will look +for a file at the path described by the rest of the request path, inside the + *static-files/* directory of the path you run the program from. + +In other words: If a client requests `/static/foo.txt`, the server will look for a file at +`./static-files/foo.txt`. If that file exists it'll succeed and serve the file. +If it doesn't exist, the handler will fail with a `404` status code. + +## Nested APIs + +Let's see how you can define APIs in a modular way, while avoiding repetition. +Consider this simple example: + +``` haskell +type UserAPI3 = -- view the user with given userid, in JSON + Capture "userid" Int :> Get '[JSON] User + + :<|> -- delete the user with given userid. empty response + Capture "userid" Int :> Delete '[] () +``` + +We can instead factor out the `userid`: + +``` haskell +type UserAPI4 = Capture "userid" Int :> + ( Get '[JSON] User + :<|> Delete '[] () + ) +``` + +However, you have to be aware that this has an effect on the type of the +corresponding `Server`: + +``` haskell ignore +Server UserAPI3 = (Int -> ExceptT ServantErr IO User) + :<|> (Int -> ExceptT ServantErr IO ()) + +Server UserAPI4 = Int -> ( ExceptT ServantErr IO User + :<|> ExceptT ServantErr IO () + ) +``` + +In the first case, each handler receives the *userid* argument. In the latter, +the whole `Server` takes the *userid* and has handlers that are just +computations in `ExceptT`, with no arguments. In other words: + +``` haskell +server8 :: Server UserAPI3 +server8 = getUser :<|> deleteUser + + where getUser :: Int -> ExceptT ServantErr IO User + getUser _userid = error "..." + + deleteUser :: Int -> ExceptT ServantErr IO () + deleteUser _userid = error "..." + +-- notice how getUser and deleteUser +-- have a different type! no argument anymore, +-- the argument directly goes to the whole Server +server9 :: Server UserAPI4 +server9 userid = getUser userid :<|> deleteUser userid + + where getUser :: Int -> ExceptT ServantErr IO User + getUser = error "..." + + deleteUser :: Int -> ExceptT ServantErr IO () + deleteUser = error "..." +``` + +Note that there's nothing special about `Capture` that lets you "factor it +out": this can be done with any combinator. Here are a few examples of APIs +with a combinator factored out for which we can write a perfectly valid +`Server`. + +``` haskell +-- we just factor out the "users" path fragment +type API1 = "users" :> + ( Get '[JSON] [User] -- user listing + :<|> Capture "userid" Int :> Get '[JSON] User -- view a particular user + ) + +-- we factor out the Request Body +type API2 = ReqBody '[JSON] User :> + ( Get '[JSON] User -- just display the same user back, don't register it + :<|> Post '[JSON] () -- register the user. empty response + ) + +-- we factor out a Header +type API3 = Header "Authorization" Token :> + ( Get '[JSON] SecretData -- get some secret data, if authorized + :<|> ReqBody '[JSON] SecretData :> Post '[] () -- add some secret data, if authorized + ) + +newtype Token = Token ByteString +newtype SecretData = SecretData ByteString +``` + +This approach lets you define APIs modularly and assemble them all into one big +API type only at the end. + +``` haskell +type UsersAPI = + Get '[JSON] [User] -- list users + :<|> ReqBody '[JSON] User :> Post '[] () -- add a user + :<|> Capture "userid" Int :> + ( Get '[JSON] User -- view a user + :<|> ReqBody '[JSON] User :> Put '[] () -- update a user + :<|> Delete '[] () -- delete a user + ) + +usersServer :: Server UsersAPI +usersServer = getUsers :<|> newUser :<|> userOperations + + where getUsers :: ExceptT ServantErr IO [User] + getUsers = error "..." + + newUser :: User -> ExceptT ServantErr IO () + newUser = error "..." + + userOperations userid = + viewUser userid :<|> updateUser userid :<|> deleteUser userid + + where + viewUser :: Int -> ExceptT ServantErr IO User + viewUser = error "..." + + updateUser :: Int -> User -> ExceptT ServantErr IO () + updateUser = error "..." + + deleteUser :: Int -> ExceptT ServantErr IO () + deleteUser = error "..." +``` + +``` haskell +type ProductsAPI = + Get '[JSON] [Product] -- list products + :<|> ReqBody '[JSON] Product :> Post '[] () -- add a product + :<|> Capture "productid" Int :> + ( Get '[JSON] Product -- view a product + :<|> ReqBody '[JSON] Product :> Put '[] () -- update a product + :<|> Delete '[] () -- delete a product + ) + +data Product = Product { productId :: Int } + +productsServer :: Server ProductsAPI +productsServer = getProducts :<|> newProduct :<|> productOperations + + where getProducts :: ExceptT ServantErr IO [Product] + getProducts = error "..." + + newProduct :: Product -> ExceptT ServantErr IO () + newProduct = error "..." + + productOperations productid = + viewProduct productid :<|> updateProduct productid :<|> deleteProduct productid + + where + viewProduct :: Int -> ExceptT ServantErr IO Product + viewProduct = error "..." + + updateProduct :: Int -> Product -> ExceptT ServantErr IO () + updateProduct = error "..." + + deleteProduct :: Int -> ExceptT ServantErr IO () + deleteProduct = error "..." +``` + +``` haskell +type CombinedAPI = "users" :> UsersAPI + :<|> "products" :> ProductsAPI + +server10 :: Server CombinedAPI +server10 = usersServer :<|> productsServer +``` + +Finally, we can realize the user and product APIs are quite similar and +abstract that away: + +``` haskell +-- API for values of type 'a' +-- indexed by values of type 'i' +type APIFor a i = + Get '[JSON] [a] -- list 'a's + :<|> ReqBody '[JSON] a :> Post '[] () -- add an 'a' + :<|> Capture "id" i :> + ( Get '[JSON] a -- view an 'a' given its "identifier" of type 'i' + :<|> ReqBody '[JSON] a :> Put '[] () -- update an 'a' + :<|> Delete '[] () -- delete an 'a' + ) + +-- Build the appropriate 'Server' +-- given the handlers of the right type. +serverFor :: ExceptT ServantErr IO [a] -- handler for listing of 'a's + -> (a -> ExceptT ServantErr IO ()) -- handler for adding an 'a' + -> (i -> ExceptT ServantErr IO a) -- handler for viewing an 'a' given its identifier of type 'i' + -> (i -> a -> ExceptT ServantErr IO ()) -- updating an 'a' with given id + -> (i -> ExceptT ServantErr IO ()) -- deleting an 'a' given its id + -> Server (APIFor a i) +serverFor = error "..." +-- implementation left as an exercise. contact us on IRC +-- or the mailing list if you get stuck! +``` + +## Using another monad for your handlers + +Remember how `Server` turns combinators for HTTP methods into `ExceptT +ServantErr IO`? Well, actually, there's more to that. `Server` is actually a +simple type synonym. + +``` haskell ignore +type Server api = ServerT api (ExceptT ServantErr IO) +``` + +`ServerT` is the actual type family that computes the required types for the +handlers that's part of the `HasServer` class. It's like `Server` except that +it takes another parameter which is the monad you want your handlers to run in, +or more generally the return types of your handlers. This third parameter is +used for specifying the return type of the handler for an endpoint, e.g when +computing `ServerT (Get '[JSON] Person) SomeMonad`. The result would be +`SomeMonad Person`. + +The first and main question one might have then is: how do we write handlers +that run in another monad? How can we "bring back" the value from a given monad +into something **servant** can understand? + +### Natural transformations + +If we have a function that gets us from an `m a` to an `n a`, for any `a`, what +do we have? + +``` haskell ignore +newtype m :~> n = Nat { unNat :: forall a. m a -> n a} +``` + +For example: + +``` haskell +listToMaybeNat :: [] :~> Maybe +listToMaybeNat = Nat listToMaybe -- from Data.Maybe +``` + +(`Nat` comes from "natural transformation", in case you're wondering.) + +So if you want to write handlers using another monad/type than `ExceptT +ServantErr IO`, say the `Reader String` monad, the first thing you have to +prepare is a function: + +``` haskell ignore +readerToHandler :: Reader String :~> ExceptT ServantErr IO +``` + +Let's start with `readerToHandler'`. We obviously have to run the `Reader` +computation by supplying it with a `String`, like `"hi"`. We get an `a` out +from that and can then just `return` it into `ExceptT`. We can then just wrap +that function with the `Nat` constructor to make it have the fancier type. + +``` haskell +readerToHandler' :: forall a. Reader String a -> ExceptT ServantErr IO a +readerToHandler' r = return (runReader r "hi") + +readerToHandler :: Reader String :~> ExceptT ServantErr IO +readerToHandler = Nat readerToHandler' +``` + +We can write some simple webservice with the handlers running in `Reader String`. + +``` haskell +type ReaderAPI = "a" :> Get '[JSON] Int + :<|> "b" :> Get '[JSON] String + +readerAPI :: Proxy ReaderAPI +readerAPI = Proxy + +readerServerT :: ServerT ReaderAPI (Reader String) +readerServerT = a :<|> b + + where a :: Reader String Int + a = return 1797 + + b :: Reader String String + b = ask +``` + +We unfortunately can't use `readerServerT` as an argument of `serve`, because +`serve` wants a `Server ReaderAPI`, i.e., with handlers running in `ExceptT +ServantErr IO`. But there's a simple solution to this. + +### Enter `enter` + +That's right. We have just written `readerToHandler`, which is exactly what we +would need to apply to all handlers to make the handlers have the +right type for `serve`. Being cumbersome to do by hand, we provide a function +`enter` which takes a natural transformation between two parametrized types `m` +and `n` and a `ServerT someapi m`, and returns a `ServerT someapi n`. + +In our case, we can wrap up our little webservice by using `enter +readerToHandler` on our handlers. + +``` haskell +readerServer :: Server ReaderAPI +readerServer = enter readerToHandler readerServerT + +app4 :: Application +app4 = serve readerAPI readerServer +``` + +This is the webservice in action: + +``` bash +$ curl http://localhost:8081/a +1797 +$ curl http://localhost:8081/b +"hi" +``` + +## Conclusion + +You're now equipped to write webservices/web-applications using +**servant**. The rest of this document focuses on **servant-client**, +**servant-js** and **servant-docs**. diff --git a/doc/tutorial/Setup.hs b/doc/tutorial/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/doc/tutorial/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/tutorial/index.rst b/doc/tutorial/index.rst new file mode 100644 index 00000000..1f48cdeb --- /dev/null +++ b/doc/tutorial/index.rst @@ -0,0 +1,24 @@ +Tutorial +======== + +This is an introductory tutorial to **servant**. + +.. note:: + This tutorial is for the latest version of servant. The tutorial for + servant-0.4 can be viewed + `here `_. + +(Any comments, issues or feedback about the tutorial can be handled +through +`servant's issue tracker `_.) + + +.. toctree:: + :maxdepth: 1 + + ApiType.lhs + Server.lhs + Client.lhs + Javascript.lhs + Docs.lhs + Authentication.lhs diff --git a/servant-examples/tutorial/t9/index.html b/doc/tutorial/static/index.html similarity index 88% rename from servant-examples/tutorial/t9/index.html rename to doc/tutorial/static/index.html index 7ec49c70..bfc55b59 100644 --- a/servant-examples/tutorial/t9/index.html +++ b/doc/tutorial/static/index.html @@ -3,11 +3,11 @@ - Tutorial - 9 - servant-jquery + servant-js Example

Books

- +

Results for ""

    @@ -23,4 +23,4 @@ - \ No newline at end of file + diff --git a/servant-examples/tutorial/t9/ui.js b/doc/tutorial/static/ui.js similarity index 99% rename from servant-examples/tutorial/t9/ui.js rename to doc/tutorial/static/ui.js index 7148827a..8bcae8d8 100644 --- a/servant-examples/tutorial/t9/ui.js +++ b/doc/tutorial/static/ui.js @@ -58,4 +58,3 @@ function refresh() } window.setInterval(refresh, 200); - diff --git a/doc/tutorial/test/JavascriptSpec.hs b/doc/tutorial/test/JavascriptSpec.hs new file mode 100644 index 00000000..2d6007a5 --- /dev/null +++ b/doc/tutorial/test/JavascriptSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE OverloadedStrings #-} + +module JavascriptSpec where + +import Data.List +import Data.String +import Data.String.Conversions +import Test.Hspec +import Test.Hspec.Wai + +import Javascript + +spec :: Spec +spec = do + describe "apiJS" $ do + it "is contained verbatim in Javascript.lhs" $ do + code <- readFile "Javascript.lhs" + cs apiJS `shouldSatisfy` (`isInfixOf` code) + + describe "writeJSFiles" $ do + it "[not a test] write apiJS to static/api.js" $ do + writeJSFiles + + describe "app" $ with (return app) $ do + context "/api.js" $ do + it "delivers apiJS" $ do + get "/api.js" `shouldRespondWith` (fromString (cs apiJS)) + + context "/" $ do + it "delivers something" $ do + get "" `shouldRespondWith` 200 + get "/" `shouldRespondWith` 200 diff --git a/doc/tutorial/test/Spec.hs b/doc/tutorial/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/doc/tutorial/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/doc/tutorial/tinc.yaml b/doc/tutorial/tinc.yaml new file mode 100644 index 00000000..f52bab2d --- /dev/null +++ b/doc/tutorial/tinc.yaml @@ -0,0 +1,13 @@ +dependencies: + - name: servant + path: ../../servant + - name: servant-server + path: ../../servant-server + - name: servant-client + path: ../../servant-client + - name: servant-js + path: ../../servant-js + - name: servant-docs + path: ../../servant-docs + - name: servant-foreign + path: ../../servant-foreign diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal new file mode 100644 index 00000000..e475ffaf --- /dev/null +++ b/doc/tutorial/tutorial.cabal @@ -0,0 +1,65 @@ +name: tutorial +version: 0.6 +synopsis: The servant tutorial +homepage: http://haskell-servant.github.io/ +license: BSD3 +license-file: LICENSE +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: ApiType + , Authentication + , Client + , Docs + , Javascript + , Server + build-depends: base == 4.* + , base-compat + , text + , aeson + , aeson-compat + , blaze-html + , directory + , blaze-markup + , containers + , servant == 0.6.* + , servant-server == 0.6.* + , servant-client == 0.6.* + , servant-docs == 0.6.* + , servant-js == 0.6.* + , warp + , http-media + , lucid + , time + , string-conversions + , bytestring + , attoparsec + , mtl + , random + , js-jquery + , wai + , http-types + , transformers + , markdown-unlit >= 0.4 + , http-client + default-language: Haskell2010 + ghc-options: -Wall -Werror -pgmL markdown-unlit + -- to silence aeson-0.10 warnings: + ghc-options: -fno-warn-missing-methods + ghc-options: -fno-warn-name-shadowing + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing -fno-warn-missing-signatures + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base == 4.* + , tutorial + , hspec + , hspec-wai + , string-conversions diff --git a/scripts/README.md b/scripts/README.md new file mode 100644 index 00000000..1f3eae98 --- /dev/null +++ b/scripts/README.md @@ -0,0 +1,8 @@ +The release process works roughly like this: + +``` bash +./scripts/bump-versions.sh +git commit +./scripts/upload.hs +git tag && git push --tags +``` diff --git a/scripts/bump-versions.sh b/scripts/bump-versions.sh index 2e39cea3..aaa3d0c2 100755 --- a/scripts/bump-versions.sh +++ b/scripts/bump-versions.sh @@ -56,10 +56,7 @@ done if $DRY_RUN ; then echo "Would have bumped position ${POSITION} on these packages:" - ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , "${SOURCES[@]}") ) + ( cd "$ROOT" && bumper --dry-run -"$POSITION" $(join , $SOURCES tutorial) ) else - ( cd "$ROOT" && bumper -"$POSITION" $(join , "${SOURCES[@]}") ) + ( cd "$ROOT" && bumper -"$POSITION" $(join , $SOURCES tutorial) ) fi - -# Trailing newline, bumper does not ship with its own. -echo diff --git a/scripts/upload.hs b/scripts/upload.hs new file mode 100755 index 00000000..b44dee78 --- /dev/null +++ b/scripts/upload.hs @@ -0,0 +1,14 @@ +#!/usr/bin/env stack +{- stack +--resolver lts-3.10 +--install-ghc runghc +-} + +import Data.Foldable +import System.Process + +main :: IO () +main = do + sources <- words <$> readFile "sources.txt" + forM_ sources $ \ source -> do + callCommand ("stack upload " ++ source) diff --git a/scripts/upload.sh b/scripts/upload.sh deleted file mode 100755 index 344b8e4a..00000000 --- a/scripts/upload.sh +++ /dev/null @@ -1,52 +0,0 @@ -#!/usr/bin/env bash -#=============================================================================== -# -# FILE: upload.sh -# -# USAGE: ./upload.sh -# -# DESCRIPTION: Uploads all servant packages to Hackage -# -# REQUIREMENTS: cabal, bash >= 4 -# AUTHOR: Julian K. Arni -# CREATED: 05.06.2015 13:05 -#=============================================================================== - -set -o nounset -set -o errexit - -DIR=$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd ) -. "$DIR"/lib/common.sh - -usage () { - echo " upload.sh " - echo " Uploads all servant packages to Hackage" - exit 0 -} - - -upload_package () { - local package="$1" - local user="$2" - local pass="$3" - local cabalFile="$package.cabal" - pushd "$package" - local version=$(grep -i '^version:' $cabalFile | awk '{ print $2 }') - local sdist="dist/${package}-${version}.tar.gz" - cabal sdist - echo "User is: $user" - cabal upload --user="$user" --password="$pass" "$sdist" - popd -} - - -if [ $# -ne 2 ] ; then - echo "expecting two arguments." - usage -fi - -versions_equal - -for s in ${SOURCES[@]} ; do - upload_package "$s" "$1" "$2" -done diff --git a/servant-blaze/LICENSE b/servant-blaze/LICENSE index 0b0a2174..1d0ce8da 100644 --- a/servant-blaze/LICENSE +++ b/servant-blaze/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-blaze/include/overlapping-compat.h b/servant-blaze/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-blaze/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-blaze/servant-blaze.cabal b/servant-blaze/servant-blaze.cabal index 08b27e24..f51c49cf 100644 --- a/servant-blaze/servant-blaze.cabal +++ b/servant-blaze/servant-blaze.cabal @@ -2,18 +2,18 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-blaze -version: 0.5 +version: 0.6 synopsis: Blaze-html support for servant -- description: homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant/issues source-repository head @@ -25,8 +25,9 @@ library -- other-modules: -- other-extensions: build-depends: base >=4.7 && <5 - , servant == 0.5.* + , servant == 0.6.* , http-media , blaze-html hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-blaze/src/Servant/HTML/Blaze.hs b/servant-blaze/src/Servant/HTML/Blaze.hs index 7870022d..822a7ae9 100644 --- a/servant-blaze/src/Servant/HTML/Blaze.hs +++ b/servant-blaze/src/Servant/HTML/Blaze.hs @@ -3,10 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @blaze-html@'s -- `ToMarkup` class and `Html` datatype. -- You should only need to import this module for it's instances and the @@ -29,17 +27,9 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ToMarkup a => MimeRender HTML a where +instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where mimeRender _ = renderHtml . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - MimeRender HTML Html where +instance OVERLAPPING_ MimeRender HTML Html where mimeRender _ = renderHtml diff --git a/servant-cassava/LICENSE b/servant-cassava/LICENSE index 0b0a2174..1d0ce8da 100644 --- a/servant-cassava/LICENSE +++ b/servant-cassava/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-cassava/include/overlapping-compat.h b/servant-cassava/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-cassava/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-cassava/servant-cassava.cabal b/servant-cassava/servant-cassava.cabal index 4d74612a..ccb37b07 100644 --- a/servant-cassava/servant-cassava.cabal +++ b/servant-cassava/servant-cassava.cabal @@ -2,18 +2,18 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-cassava -version: 0.4.4.2 +version: 0.6 synopsis: Servant CSV content-type for cassava -- description: homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors -- category: build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 library @@ -22,8 +22,9 @@ library -- other-extensions: build-depends: base >=4.6 && <5 , cassava >0.4 && <0.5 - , servant ==0.5.* + , servant == 0.6.* , http-media , vector hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 2c9f5279..ada41eb0 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,13 +1,21 @@ -HEAD ----- +0.6 +--- + +* `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments. + +0.5 +--- * Use the `text` package instead of `String`. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Added support for `path` on `BaseUrl`. * `client` now takes an explicit `Manager` argument. * Use `http-api-data` instead of `Servant.Common.Text` -* Client functions now consider any 2xx succesful. +* Client functions now consider any 2xx successful. * Remove matrix params. +* Added support for Basic authentication +* Add generalized authentication support via the `AuthClientData` type family and + `AuthenticateReq` data type 0.4.1 ----- diff --git a/servant-client/LICENSE b/servant-client/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-client/LICENSE +++ b/servant-client/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-client/include/overlapping-compat.h b/servant-client/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-client/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index e60e1400..d5aa1a4b 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,5 +1,5 @@ name: servant-client -version: 0.5 +version: 0.6 synopsis: automatical derivation of querying functions for servant webservices description: This library lets you derive automatically Haskell functions that @@ -10,11 +10,12 @@ description: license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/ @@ -26,7 +27,9 @@ source-repository head library exposed-modules: Servant.Client + Servant.Client.Experimental.Auth Servant.Common.BaseUrl + Servant.Common.BasicAuth Servant.Common.Req other-modules: Servant.Client.PerformRequest @@ -41,7 +44,9 @@ library base >=4.7 && <5 , aeson , attoparsec + , base64-bytestring , bytestring + , case-insensitive , exceptions , http-api-data >= 0.1 && < 0.3 , http-client @@ -50,7 +55,7 @@ library , http-types , network-uri >= 2.6 , safe - , servant == 0.5.* + , servant == 0.6.* , string-conversions , text , transformers @@ -59,10 +64,10 @@ library build-depends: ghcjs-base , ghcjs-prim - , case-insensitive hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 @@ -88,6 +93,7 @@ test-suite spec , transformers , transformers-compat , aeson + , base64-bytestring , bytestring , deepseq , hspec >= 2.2.1 && < 2.3 @@ -97,8 +103,8 @@ test-suite spec , HUnit , network >= 2.6 , QuickCheck >= 2.7 - , servant == 0.5.* - , servant-server == 0.5.* + , servant == 0.6.* + , servant-server == 0.6.* , text , wai , warp @@ -114,3 +120,4 @@ test-suite spec ghcjs-base , ghcjs-prim , case-insensitive + include-dirs: include diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 3ef63c4a..07df5e2a 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -4,19 +4,23 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | This module provides 'client' which can automatically generate -- querying functions for each endpoint just from the type representing your -- API. module Servant.Client - ( client + ( AuthClientData + , AuthenticateReq(..) + , client , HasClient(..) + , ClientM + , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl ) where @@ -24,20 +28,20 @@ module Servant.Client #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad -import Control.Monad.Trans.Except import Data.ByteString.Lazy (ByteString) import Data.List import Data.Proxy import Data.String.Conversions import Data.Text (unpack) import GHC.TypeLits -import Network.HTTP.Client (Response, Manager) +import Network.HTTP.Client (Manager, Response) import Network.HTTP.Media import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types.Header as HTTP import Servant.API +import Servant.Client.Experimental.Auth import Servant.Common.BaseUrl +import Servant.Common.BasicAuth import Servant.Common.Req import Servant.Client.PerformRequest (ServantError(..)) @@ -46,24 +50,23 @@ import Servant.Client.PerformRequest (ServantError(..)) -- | 'client' allows you to produce operations to query an API from a client. -- -- > type MyApi = "books" :> Get '[JSON] [Book] -- GET /books --- > :<|> "books" :> ReqBody '[JSON] Book :> Post Book -- POST /books +-- > :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -- POST /books -- > -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ExceptT String IO [Book] --- > postNewBook :: Book -> ExceptT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 -client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout -client p baseurl = clientWithRoute p defReq baseurl +-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book] +-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi +client :: HasClient layout => Proxy layout -> Client layout +client p = clientWithRoute p defReq -- | This class lets us define how each API combinator -- influences the creation of an HTTP request. It's mostly -- an internal class, you can just use 'client'. class HasClient layout where type Client layout :: * - clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout + clientWithRoute :: Proxy layout -> Req -> Client layout -- | A client querying function for @a ':<|>' b@ will actually hand you @@ -76,15 +79,14 @@ class HasClient layout where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getAllBooks :: ExceptT String IO [Book] --- > postNewBook :: Book -> ExceptT String IO Book --- > (getAllBooks :<|> postNewBook) = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book] +-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book +-- > (getAllBooks :<|> postNewBook) = client myApi instance (HasClient a, HasClient b) => HasClient (a :<|> b) where type Client (a :<|> b) = Client a :<|> Client b - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|> - clientWithRoute (Proxy :: Proxy b) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy a) req :<|> + clientWithRoute (Proxy :: Proxy b) req -- | If you use a 'Capture' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -102,9 +104,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBook :: Text -> ExceptT String IO Book --- > getBook = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book +-- > getBook = client myApi -- > -- then you can just use "getBook" to query that endpoint instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) => HasClient (Capture capture a :> sublayout) where @@ -112,88 +113,55 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) type Client (Capture capture a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager val = + clientWithRoute Proxy req val = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl - manager where p = unpack (toUrlPiece val) --- | If you have a 'Delete' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where - type Client (Delete cts' a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager +instance OVERLAPPABLE_ + -- Note [Non-Empty Content Types] + (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' a) where + type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a + clientWithRoute Proxy req manager baseurl = + snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl + where method = reflectMethod (Proxy :: Proxy method) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Delete cts ()) where - type Client (Delete cts ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodDelete req baseurl manager +instance OVERLAPPING_ + (ReflectMethod method) => HasClient (Verb method status cts NoContent) where + type Client (Verb method status cts NoContent) + = Manager -> BaseUrl -> ClientM NoContent + clientWithRoute Proxy req manager baseurl = + performRequestNoBody method req manager baseurl >> return NoContent + where method = reflectMethod (Proxy :: Proxy method) --- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) - ) => HasClient (Delete cts' (Headers ls a)) where - type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req baseurl manager +instance OVERLAPPING_ + -- Note [Non-Empty Content Types] + ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) + ) => HasClient (Verb method status cts' (Headers ls a)) where + type Client (Verb method status cts' (Headers ls a)) + = Manager -> BaseUrl -> ClientM (Headers ls a) + clientWithRoute Proxy req manager baseurl = do + let method = reflectMethod (Proxy :: Proxy method) + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } --- | If you have a 'Get' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where - type Client (Get (ct ': cts) result) = ExceptT ServantError IO result - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Get (ct ': cts) ()) where - type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - performRequestNoBody H.methodGet req baseurl manager - --- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Get (ct ': cts) (Headers ls a)) where - type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req baseurl manager - return $ Headers { getResponse = resp +instance OVERLAPPING_ + ( BuildHeadersTo ls, ReflectMethod method + ) => HasClient (Verb method status cts (Headers ls NoContent)) where + type Client (Verb method status cts (Headers ls NoContent)) + = Manager -> BaseUrl -> ClientM (Headers ls NoContent) + clientWithRoute Proxy req manager baseurl = do + let method = reflectMethod (Proxy :: Proxy method) + hdrs <- performRequestNoBody method req manager baseurl + return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } + -- | If you use a 'Header' in one of your endpoints in your API, -- the corresponding querying function will automatically take -- an additional argument of the type specified by your 'Header', @@ -207,7 +175,7 @@ instance -- Example: -- -- > newtype Referer = Referer { referrer :: Text } --- > deriving (Eq, Show, Generic, FromText, ToHttpApiData) +-- > deriving (Eq, Show, Generic, ToHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer @@ -215,9 +183,8 @@ instance -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > viewReferer :: Maybe Referer -> ExceptT String IO Book --- > viewReferer = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > viewReferer :: Maybe Referer -> Manager -> BaseUrl -> ClientM Book +-- > viewReferer = client myApi -- > -- then you can just use "viewRefer" to query that endpoint -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) @@ -226,127 +193,25 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) type Client (Header sym a :> sublayout) = Maybe a -> Client sublayout - clientWithRoute Proxy req baseurl manager mval = + clientWithRoute Proxy req mval = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval ) - baseurl - manager where hname = symbolVal (Proxy :: Proxy sym) --- | If you have a 'Post' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where - type Client (Post (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager +-- | Using a 'HttpVersion' combinator in your API doesn't affect the client +-- functions. +instance HasClient sublayout + => HasClient (HttpVersion :> sublayout) where -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Post (ct ': cts) ()) where - type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPost req baseurl manager + type Client (HttpVersion :> sublayout) = + Client sublayout --- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Post (ct ': cts) (Headers ls a)) where - type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Put' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where - type Client (Put (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Put (ct ': cts) ()) where - type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPut req baseurl manager - --- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Put (ct ': cts) (Headers ls a)) where - type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager= do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } - --- | If you have a 'Patch' endpoint in your API, the client --- side querying function that is created when calling 'client' --- will just require an argument that specifies the scheme, host --- and port to send the request to. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where - type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a - clientWithRoute Proxy req baseurl manager = - snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasClient (Patch (ct ': cts) ()) where - type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () - clientWithRoute Proxy req baseurl manager = - void $ performRequestNoBody H.methodPatch req baseurl manager - --- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the --- corresponding headers. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( MimeUnrender ct a, BuildHeadersTo ls - ) => HasClient (Patch (ct ': cts) (Headers ls a)) where - type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) - clientWithRoute Proxy req baseurl manager = do - (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req baseurl manager - return $ Headers { getResponse = resp - , getHeadersHList = buildHeadersTo hdrs - } + clientWithRoute Proxy = + clientWithRoute (Proxy :: Proxy sublayout) -- | If you use a 'QueryParam' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -368,9 +233,8 @@ instance -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: Maybe Text -> ExceptT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooksBy :: Maybe Text -> Manager -> BaseUrl -> ClientM [Book] +-- > getBooksBy = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy Nothing' for all books -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov @@ -381,14 +245,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) Maybe a -> Client sublayout -- if mparam = Nothing, we don't add it to the query string - clientWithRoute Proxy req baseurl manager mparam = + clientWithRoute Proxy req mparam = clientWithRoute (Proxy :: Proxy sublayout) (maybe req (flip (appendToQueryString pname) req . Just) mparamText ) - baseurl - manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -415,9 +277,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooksBy :: [Text] -> ExceptT String IO [Book] --- > getBooksBy = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooksBy :: [Text] -> Manager -> BaseUrl -> ClientM [Book] +-- > getBooksBy = client myApi -- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- 'getBooksBy []' for all books -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' @@ -428,13 +289,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) type Client (QueryParams sym a :> sublayout) = [a] -> Client sublayout - clientWithRoute Proxy req baseurl manager paramlist = + clientWithRoute Proxy req paramlist = clientWithRoute (Proxy :: Proxy sublayout) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) req paramlist' ) - baseurl manager where pname = cs pname' pname' = symbolVal (Proxy :: Proxy sym) @@ -456,9 +316,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > getBooks :: Bool -> ExceptT String IO [Book] --- > getBooks = client myApi host --- > where host = BaseUrl Http "localhost" 8080 +-- > getBooks :: Bool -> Manager -> BaseUrl -> ClientM [Book] +-- > getBooks = client myApi -- > -- then you can just use "getBooks" to query that endpoint. -- > -- 'getBooksBy False' for all books -- > -- 'getBooksBy True' to only get _already published_ books @@ -468,13 +327,12 @@ instance (KnownSymbol sym, HasClient sublayout) type Client (QueryFlag sym :> sublayout) = Bool -> Client sublayout - clientWithRoute Proxy req baseurl manager flag = + clientWithRoute Proxy req flag = clientWithRoute (Proxy :: Proxy sublayout) (if flag then appendToQueryString paramname Nothing req else req ) - baseurl manager where paramname = cs $ symbolVal (Proxy :: Proxy sym) @@ -482,11 +340,12 @@ instance (KnownSymbol sym, HasClient sublayout) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. instance HasClient Raw where - type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + type Client Raw + = H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) - clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw - clientWithRoute Proxy req baseurl manager httpMethod = do - performRequest httpMethod req baseurl manager + clientWithRoute :: Proxy Raw -> Req -> Client Raw + clientWithRoute Proxy req httpMethod = do + performRequest httpMethod req -- | If you use a 'ReqBody' in one of your endpoints in your API, -- the corresponding querying function will automatically take @@ -503,9 +362,8 @@ instance HasClient Raw where -- > myApi :: Proxy MyApi -- > myApi = Proxy -- > --- > addBook :: Book -> ExceptT String IO Book --- > addBook = client myApi host manager --- > where host = BaseUrl Http "localhost" 8080 +-- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book +-- > addBook = client myApi -- > -- then you can just use "addBook" to query that endpoint instance (MimeRender ct a, HasClient sublayout) => HasClient (ReqBody (ct ': cts) a :> sublayout) where @@ -513,40 +371,77 @@ instance (MimeRender ct a, HasClient sublayout) type Client (ReqBody (ct ': cts) a :> sublayout) = a -> Client sublayout - clientWithRoute Proxy req baseurl manager body = + clientWithRoute Proxy req body = clientWithRoute (Proxy :: Proxy sublayout) (let ctProxy = Proxy :: Proxy ct in setRQBody (mimeRender ctProxy body) (contentType ctProxy) req ) - baseurl manager -- | Make the querying function append @path@ to the request path. instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where type Client (path :> sublayout) = Client sublayout - clientWithRoute Proxy req baseurl manager = + clientWithRoute Proxy req = clientWithRoute (Proxy :: Proxy sublayout) (appendToPath p req) - baseurl manager where p = symbolVal (Proxy :: Proxy path) instance HasClient api => HasClient (Vault :> api) where type Client (Vault :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (RemoteHost :> api) where type Client (RemoteHost :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req instance HasClient api => HasClient (IsSecure :> api) where type Client (IsSecure :> api) = Client api - clientWithRoute Proxy req baseurl manager = - clientWithRoute (Proxy :: Proxy api) req baseurl manager + clientWithRoute Proxy req = + clientWithRoute (Proxy :: Proxy api) req + +instance HasClient subapi => + HasClient (WithNamedContext name context subapi) where + + type Client (WithNamedContext name context subapi) = Client subapi + clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi) + +instance ( HasClient api + ) => HasClient (AuthProtect tag :> api) where + type Client (AuthProtect tag :> api) + = AuthenticateReq (AuthProtect tag) -> Client api + + clientWithRoute Proxy req (AuthenticateReq (val,func)) = + clientWithRoute (Proxy :: Proxy api) (func val req) + +-- * Basic Authentication + +instance HasClient api => HasClient (BasicAuth realm usr :> api) where + type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api + + clientWithRoute Proxy req val = + clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) + + +{- Note [Non-Empty Content Types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rather than have + + instance (..., cts' ~ (ct ': cts)) => ... cts' ... + +It may seem to make more sense to have: + + instance (...) => ... (ct ': cts) ... + +But this means that if another instance exists that does *not* require +non-empty lists, but is otherwise more specific, no instance will be overall +more specific. This in turn generally means adding yet another instance (one +for empty and one for non-empty lists). +-} diff --git a/servant-client/src/Servant/Client/Experimental/Auth.hs b/servant-client/src/Servant/Client/Experimental/Auth.hs new file mode 100644 index 00000000..a98d0b41 --- /dev/null +++ b/servant-client/src/Servant/Client/Experimental/Auth.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Authentication for clients + +module Servant.Client.Experimental.Auth ( + AuthenticateReq(AuthenticateReq, unAuthReq) + , AuthClientData + , mkAuthenticateReq + ) where + +import Servant.Common.Req (Req) + +-- | For a resource protected by authentication (e.g. AuthProtect), we need +-- to provide the client with some data used to add authentication data +-- to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +type family AuthClientData a :: * + +-- | For better type inference and to avoid usage of a data family, we newtype +-- wrap the combination of some 'AuthClientData' and a function to add authentication +-- data to a request +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +newtype AuthenticateReq a = + AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) } + +-- | Handy helper to avoid wrapping datatypes in tuples everywhere. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +mkAuthenticateReq :: AuthClientData a + -> (AuthClientData a -> Req -> Req) + -> AuthenticateReq a +mkAuthenticateReq val func = AuthenticateReq (val, func) diff --git a/servant-client/src/Servant/Common/BasicAuth.hs b/servant-client/src/Servant/Common/BasicAuth.hs new file mode 100644 index 00000000..e2802699 --- /dev/null +++ b/servant-client/src/Servant/Common/BasicAuth.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Basic Authentication for clients + +module Servant.Common.BasicAuth ( + basicAuthReq + ) where + +import Data.ByteString.Base64 (encode) +import Data.Monoid ((<>)) +import Data.Text.Encoding (decodeUtf8) +import Servant.Common.Req (addHeader, Req) +import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) + +-- | Authenticate a request using Basic Authentication +basicAuthReq :: BasicAuthData -> Req -> Req +basicAuthReq (BasicAuthData user pass) req = + let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass)) + in addHeader "Authorization" authText req diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index cfe22c78..e756075e 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -18,6 +18,7 @@ import Data.String.Conversions import Data.Proxy import Data.Text (Text) import Data.Text.Encoding +import Data.Typeable import Network.HTTP.Client hiding (Proxy, path) import Network.HTTP.Media import Network.HTTP.Types @@ -30,6 +31,8 @@ import Web.HttpApiData import qualified Network.HTTP.Client as Client +import Web.HttpApiData + data Req = Req { reqPath :: String , qs :: QueryText @@ -96,18 +99,19 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" +type ClientM = ExceptT ServantError IO -performRequest :: Method -> Req -> BaseUrl -> Manager - -> ExceptT ServantError IO ( Int, ByteString, MediaType - , [HTTP.Header], Response ByteString) -performRequest reqMethod req reqHost manager = do +performRequest :: Method -> Req -> Manager -> BaseUrl + -> ClientM ( Int, ByteString, MediaType + , [HTTP.Header], Response ByteString) +performRequest reqMethod req manager reqHost = do partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod , checkStatus = \ _status _headers _cookies -> Nothing } - eResponse <- liftIO $ performHttpRequest manager request + eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager case eResponse of Left err -> throwE . ConnectionError $ SomeException err @@ -115,7 +119,7 @@ performRequest reqMethod req reqHost manager = do Right response -> do let status = Client.responseStatus response body = Client.responseBody response - hrds = Client.responseHeaders response + hdrs = Client.responseHeaders response status_code = statusCode status ct <- case lookup "Content-Type" $ Client.responseHeaders response of Nothing -> pure $ "application"//"octet-stream" @@ -124,20 +128,28 @@ performRequest reqMethod req reqHost manager = do Just t' -> pure t' unless (status_code >= 200 && status_code < 300) $ throwE $ FailureResponse status ct body - return (status_code, body, ct, hrds, response) + return (status_code, body, ct, hdrs, response) performRequestCT :: MimeUnrender ct result => - Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result) -performRequestCT ct reqMethod req reqHost manager = do + Proxy ct -> Method -> Req -> Manager -> BaseUrl + -> ClientM ([HTTP.Header], result) +performRequestCT ct reqMethod req manager reqHost = do let acceptCT = contentType ct - (_status, respBody, respCT, hrds, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager + (_status, respBody, respCT, hdrs, _response) <- + performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody case mimeUnrender ct respBody of Left err -> throwE $ DecodeFailure err respCT respBody - Right val -> return (hrds, val) + Right val -> return (hdrs, val) -performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO () -performRequestNoBody reqMethod req reqHost manager = - void $ performRequest reqMethod req reqHost manager +performRequestNoBody :: Method -> Req -> Manager -> BaseUrl + -> ClientM [HTTP.Header] +performRequestNoBody reqMethod req manager reqHost = do + (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost + return hdrs + +catchConnectionError :: IO a -> IO (Either ServantError a) +catchConnectionError action = + catch (Right <$> action) $ \e -> + pure . Left . ConnectionError $ SomeException (e :: HttpException) diff --git a/servant-client/stack-ghcjs.yaml b/servant-client/stack-ghcjs.yaml index 437fe3e0..344c9b71 100644 --- a/servant-client/stack-ghcjs.yaml +++ b/servant-client/stack-ghcjs.yaml @@ -7,15 +7,15 @@ packages: - location: ../servant-server extra-dep: true -resolver: lts-3.10 +resolver: lts-5.11 -compiler: ghcjs-0.2.0.20151029_ghc-7.10.2 +compiler: ghcjs-0.2.0.20160315_ghc-7.10.2 compiler-check: match-exact setup-info: - ghcjs: - source: - ghcjs-0.2.0.20151029_ghc-7.10.2: - url: "https://github.com/nrolland/ghcjs/releases/download/v0.2.0.20151029/ghcjs-0.2.0.20151029.tar.gz" + ghcjs: + source: + ghcjs-0.2.0.20160315_ghc-7.10.2: + url: "https://github.com/nrolland/ghcjs/releases/download/v.0.2.0.20160315/ghcjs-0.2.0.20160315.tar.gz" extra-deps: - hspec-expectations-0.7.2 diff --git a/servant-client/test/Servant/Client/TestServer.hs b/servant-client/test/Servant/Client/TestServer.hs index 3e0a4057..b1efb388 100644 --- a/servant-client/test/Servant/Client/TestServer.hs +++ b/servant-client/test/Servant/Client/TestServer.hs @@ -4,7 +4,7 @@ module Servant.Client.TestServer ( buildTestServer, TestServer(..), withServer, -)where +) where #ifdef __GHCJS__ import Servant.Client.TestServer.GHCJS diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index dbe74cf0..3999be3c 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -6,40 +6,36 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fcontext-stack=100 #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.ClientSpec where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), pure) +import Control.Applicative ((<$>)) #endif import Control.Arrow (left) import Control.Monad.Trans.Except (runExceptT, throwE) import Data.Aeson +import qualified Data.ByteString.Lazy as BS import Data.Char (chr, isPrint) import Data.Foldable (forM_) import Data.Monoid hiding (getLast) import Data.Proxy import qualified Data.Text as T import GHC.Generics (Generic) -import GHC.TypeLits import qualified Network.HTTP.Client as C import Network.HTTP.Media -import Network.HTTP.Types (Status (..), badRequest400, - methodGet, ok200, status400) -import Network.Wai (responseLBS) +import qualified Network.HTTP.Types as HTTP +import Network.Wai (Application, responseLBS) +import qualified Network.Wai as Wai import System.IO.Unsafe (unsafePerformIO) import Test.HUnit import Test.Hspec @@ -49,14 +45,16 @@ import Test.QuickCheck import Servant.API import Servant.Client import Servant.Client.TestServer +import qualified Servant.Common.Req as SCR import Servant.Server +import Servant.Server.Experimental.Auth spec :: Spec -spec = do - runIO buildTestServer - describe "Servant.Client" $ do +spec = describe "Servant.Client" $ do sucessSpec failSpec + basicAuthSpec + genAuthSpec errorSpec -- | Run a test-server (identified by name) while performing the given action. @@ -129,7 +127,7 @@ type TestHeaders = '[Header "X-Example1" Int, Header "X-Example2" String] type Api = "get" :> Get '[JSON] Person - :<|> "deleteEmpty" :> Delete '[] () + :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person @@ -142,16 +140,44 @@ type Api = QueryParam "second" Int :> QueryFlag "third" :> ReqBody '[JSON] [(String, [Rational])] :> - Post '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) + Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])]) :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool) - :<|> "deleteContentType" :> Delete '[JSON] () + :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent api :: Proxy Api api = Proxy +getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person +getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent +getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person +getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person +getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person +getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person] +getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool +getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl + -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) +getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl + -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString) +getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl + -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])]) +getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool) +getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent +getGet + :<|> getDeleteEmpty + :<|> getCapture + :<|> getBody + :<|> getQueryParam + :<|> getQueryParams + :<|> getQueryFlag + :<|> getRawSuccess + :<|> getRawFailure + :<|> getMultiple + :<|> getRespHeaders + :<|> getDeleteContentType = client api + server :: TestServer server = TestServer "server" $ serve api ( return alice - :<|> return () + :<|> return NoContent :<|> (\ name -> return $ Person name 0) :<|> return :<|> (\ name -> case name of @@ -160,11 +186,11 @@ server = TestServer "server" $ serve api ( Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") - :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") + :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) - :<|> return () + :<|> return NoContent ) type FailApi = @@ -177,10 +203,56 @@ failApi = Proxy failServer :: TestServer failServer = TestServer "failServer" $ serve failApi ( - (\ _request respond -> respond $ responseLBS ok200 [] "") - :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") - :<|> (\ _request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") - ) + (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "") + :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "") + :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "") + ) + +-- * basic auth stuff + +type BasicAuthAPI = + BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person + +basicAuthAPI :: Proxy BasicAuthAPI +basicAuthAPI = Proxy + +basicAuthHandler :: BasicAuthCheck () +basicAuthHandler = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized ()) + else return Unauthorized + in BasicAuthCheck check + +basicServerContext :: Context '[ BasicAuthCheck () ] +basicServerContext = basicAuthHandler :. EmptyContext + +basicAuthServer :: Application +basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice)) + +-- * general auth stuff + +type GenAuthAPI = + AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person + +genAuthAPI :: Proxy GenAuthAPI +genAuthAPI = Proxy + +type instance AuthServerData (AuthProtect "auth-tag") = () +type instance AuthClientData (AuthProtect "auth-tag") = () + +genAuthHandler :: AuthHandler Wai.Request () +genAuthHandler = + let handler req = case lookup "AuthHeader" (Wai.requestHeaders req) of + Nothing -> throwE (err401 { errBody = "Missing auth header" }) + Just _ -> return () + in mkAuthHandler handler + +genAuthServerContext :: Context '[ AuthHandler Wai.Request () ] +genAuthServerContext = genAuthHandler :. EmptyContext + +genAuthServer :: Application +genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager @@ -190,76 +262,64 @@ sucessSpec :: Spec sucessSpec = around (withTestServer "server") $ do it "Servant.API.Get" $ \baseUrl -> do - let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager - (left show <$> runExceptT getGet) `shouldReturn` Right alice + (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice describe "Servant.API.Delete" $ do it "allows empty content type" $ \baseUrl -> do - let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager - (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right () + (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent it "allows content type" $ \baseUrl -> do - let getDeleteContentType = getLast $ client api baseUrl manager - (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right () + (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent it "Servant.API.Capture" $ \baseUrl -> do - let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager - (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0) + (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0) it "Servant.API.ReqBody" $ \baseUrl -> do let p = Person "Clara" 42 - getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager - (left show <$> runExceptT (getBody p)) `shouldReturn` Right p + (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p it "Servant.API.QueryParam" $ \baseUrl -> do - let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager - left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice - Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob")) - responseStatus `shouldBe` Status 400 "bob not found" + left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice + Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl) + responseStatus `shouldBe` HTTP.Status 400 "bob not found" it "Servant.API.QueryParam.QueryParams" $ \baseUrl -> do - let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager - (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right [] - (left show <$> runExceptT (getQueryParams ["alice", "bob"])) + (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right [] + (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl)) `shouldReturn` Right [Person "alice" 0, Person "bob" 1] context "Servant.API.QueryParam.QueryFlag" $ forM_ [False, True] $ \ flag -> it (show flag) $ \baseUrl -> do - let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager - (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag + (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag it "Servant.API.Raw on success" $ \baseUrl -> do - let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager - res <- runExceptT (getRawSuccess methodGet) + res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl) case res of Left e -> assertFailure $ show e Right (code, body, ct, _, response) -> do (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") C.responseBody response `shouldBe` body - C.responseStatus response `shouldBe` ok200 + C.responseStatus response `shouldBe` HTTP.ok200 it "Servant.API.Raw should return a Left in case of failure" $ \baseUrl -> do - let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager - res <- runExceptT (getRawFailure methodGet) + res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl) case res of Right _ -> assertFailure "expected Left, but got Right" Left e -> do - Servant.Client.responseStatus e `shouldBe` status400 + Servant.Client.responseStatus e `shouldBe` HTTP.status400 Servant.Client.responseBody e `shouldBe` "rawFailure" it "Returns headers appropriately" $ \baseUrl -> do - let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager - res <- runExceptT getRespHeaders + res <- runExceptT (getRespHeaders manager baseUrl) case res of Left e -> assertFailure $ show e Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] - modifyMaxSuccess (const 2) $ do + modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \baseUrl -> - let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager - in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> + property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> ioProperty $ do - result <- left show <$> runExceptT (getMultiple cap num flag body) + result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl) return $ result === Right (cap, num, flag, body) @@ -284,47 +344,81 @@ errorSpec = describe "error status codes" $ it "reports error statuses correctly" $ \baseUrl -> do let delete :<|> get :<|> post :<|> put = - client errorApi baseUrl manager - actions = [delete, get, post, put] + client errorApi + actions = map (\ f -> f manager baseUrl) [delete, get, post, put] forM_ actions $ \ clientAction -> do Left FailureResponse{..} <- runExceptT clientAction - responseStatus `shouldBe` Status 500 "error message" + responseStatus `shouldBe` HTTP.Status 500 "error message" + +basicAuthSpec :: Spec +basicAuthSpec = around (withTestServer "basicAuthServer") $ do + context "Authentication works when requests are properly authenticated" $ do + + it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do + let getBasic = client basicAuthAPI + let basicAuthData = BasicAuthData "servant" "server" + (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice + + context "Authentication is rejected when requests are not authenticated properly" $ do + + it "Authenticates a BasicAuth protected server appropriately" $ \baseUrl -> do + let getBasic = client basicAuthAPI + let basicAuthData = BasicAuthData "not" "password" + Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl) + responseStatus `shouldBe` HTTP.Status 403 "Forbidden" + +genAuthSpec :: Spec +genAuthSpec = around (withTestServer "genAuthServer") $ do + context "Authentication works when requests are properly authenticated" $ do + + it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do + let getProtected = client genAuthAPI + let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req) + (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice + + context "Authentication is rejected when requests are not authenticated properly" $ do + + it "Authenticates a AuthProtect protected server appropriately" $ \baseUrl -> do + let getProtected = client genAuthAPI + let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req) + Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl) + responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized") failSpec :: Spec failSpec = around (withTestServer "failServer") $ do context "client returns errors appropriately" $ do it "reports FailureResponse" $ \baseUrl -> do - let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager - Left res <- runExceptT getDeleteEmpty + let (_ :<|> getDeleteEmpty :<|> _) = client api + Left res <- runExceptT (getDeleteEmpty manager baseUrl) case res of - FailureResponse (Status 404 "Not Found") _ _ -> return () + FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return () _ -> fail $ "expected 404 response, but got " <> show res it "reports DecodeFailure" $ \baseUrl -> do - let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager - Left res <- runExceptT (getCapture "foo") + let (_ :<|> _ :<|> getCapture :<|> _) = client api + Left res <- runExceptT (getCapture "foo" manager baseUrl) case res of DecodeFailure _ ("application/json") _ -> return () _ -> fail $ "expected DecodeFailure, but got " <> show res it "reports ConnectionError" $ \_ -> do - let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager - Left res <- runExceptT getGetWrongHost + let (getGetWrongHost :<|> _) = client api + Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 "")) case res of ConnectionError _ -> return () _ -> fail $ "expected ConnectionError, but got " <> show res it "reports UnsupportedContentType" $ \baseUrl -> do - let (getGet :<|> _ ) = client api baseUrl manager - Left res <- runExceptT getGet + let (getGet :<|> _ ) = client api + Left res <- runExceptT (getGet manager baseUrl) case res of UnsupportedContentType ("application/octet-stream") _ -> return () _ -> fail $ "expected UnsupportedContentType, but got " <> show res it "reports InvalidContentTypeHeader" $ \baseUrl -> do - let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager - Left res <- runExceptT (getBody alice) + let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api + Left res <- runExceptT (getBody alice manager baseUrl) case res of InvalidContentTypeHeader "fooooo" _ -> return () _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res @@ -339,37 +433,3 @@ pathGen = fmap NonEmpty path filter (not . (`elem` ("?%[]/#;" :: String))) $ filter isPrint $ map chr [0..127] - -class GetNth (n :: Nat) a b | n a -> b where - getNth :: Proxy n -> a -> b - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetNth 0 (x :<|> y) x where - getNth _ (x :<|> _) = x - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where - getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x - -class GetLast a b | a -> b where - getLast :: a -> b - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (GetLast b c) => GetLast (a :<|> b) c where - getLast (_ :<|> b) = getLast b - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetLast a a where - getLast a = a diff --git a/servant-docs/.ghci b/servant-docs/.ghci new file mode 100644 index 00000000..0ba46fd4 --- /dev/null +++ b/servant-docs/.ghci @@ -0,0 +1 @@ +:set -itest -isrc -Iinclude diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index a5be837a..44ce0696 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,4 +1,4 @@ -HEAD +0.5 ---- * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators @@ -9,6 +9,7 @@ HEAD * Move `toSample` out of `ToSample` class * Add a few helper functions to define `toSamples` * Remove matrix params. +* Added support for Basic authentication 0.4 --- diff --git a/servant-docs/LICENSE b/servant-docs/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-docs/LICENSE +++ b/servant-docs/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-docs/include/overlapping-compat.h b/servant-docs/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-docs/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index b88bc612..878aa802 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -1,5 +1,5 @@ name: servant-docs -version: 0.5 +version: 0.6 synopsis: generate API docs for your servant webservice description: Library for generating API docs from a servant API definition. @@ -9,9 +9,9 @@ description: license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014-2015 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 @@ -19,6 +19,7 @@ tested-with: GHC >= 7.8 homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head @@ -41,7 +42,7 @@ library , http-media >= 0.6 , http-types >= 0.7 , lens - , servant == 0.5.* + , servant == 0.6.* , string-conversions , text , unordered-containers @@ -49,6 +50,7 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet-docs main-is: greet.hs diff --git a/servant-docs/src/Servant/Docs.hs b/servant-docs/src/Servant/Docs.hs index 193b4e60..9805285f 100644 --- a/servant-docs/src/Servant/Docs.hs +++ b/servant-docs/src/Servant/Docs.hs @@ -41,8 +41,7 @@ module Servant.Docs , ToCapture(..) , -- * ADTs to represent an 'API' - Method(..) - , Endpoint, path, method, defEndpoint + Endpoint, path, method, defEndpoint , API, apiIntros, apiEndpoints, emptyAPI , DocCapture(..), capSymbol, capDesc , DocQueryParam(..), ParamKind(..), paramName, paramValues, paramDesc, paramKind diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 33cb86a0..2d0cf673 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -16,18 +16,18 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Docs.Internal where import Control.Applicative import Control.Arrow (second) -import Control.Lens (makeLenses, over, traversed, (%~), +import Control.Lens (makeLenses, mapped, over, traversed, view, (%~), (&), (.~), (<>~), (^.), (|>)) import qualified Control.Monad.Omega as Omega import Data.ByteString.Conversion (ToByteString, toByteString) import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Char8 as BSC import qualified Data.CaseInsensitive as CI import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -37,7 +37,7 @@ import Data.Monoid import Data.Ord (comparing) import Data.Proxy (Proxy(Proxy)) import Data.String.Conversions (cs) -import Data.Text (Text, pack, unpack) +import Data.Text (Text, unpack) import GHC.Exts (Constraint) import GHC.Generics import GHC.TypeLits @@ -50,21 +50,6 @@ import qualified Data.Text as T import qualified Network.HTTP.Media as M import qualified Network.HTTP.Types as HTTP --- | Supported HTTP request methods -data Method = DocDELETE -- ^ the DELETE method - | DocGET -- ^ the GET method - | DocPOST -- ^ the POST method - | DocPUT -- ^ the PUT method - deriving (Eq, Ord, Generic) - -instance Show Method where - show DocGET = "GET" - show DocPOST = "POST" - show DocDELETE = "DELETE" - show DocPUT = "PUT" - -instance Hashable Method - -- | An 'Endpoint' type that holds the 'path' and the 'method'. -- -- Gets used as the key in the 'API' hashmap. Modify 'defEndpoint' @@ -76,12 +61,12 @@ instance Hashable Method -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ data Endpoint = Endpoint - { _path :: [String] -- type collected - , _method :: Method -- type collected + { _path :: [String] -- type collected + , _method :: HTTP.Method -- type collected } deriving (Eq, Ord, Generic) instance Show Endpoint where @@ -95,7 +80,7 @@ showPath :: [String] -> String showPath [] = "/" showPath ps = concatMap ('/' :) ps --- | An 'Endpoint' whose path is `"/"` and whose method is 'DocGET' +-- | An 'Endpoint' whose path is `"/"` and whose method is @GET@ -- -- Here's how you can modify it: -- @@ -104,11 +89,11 @@ showPath ps = concatMap ('/' :) ps -- GET / -- λ> 'defEndpoint' & 'path' '<>~' ["foo"] -- GET /foo --- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'DocPOST' +-- λ> 'defEndpoint' & 'path' '<>~' ["foo"] & 'method' '.~' 'HTTP.methodPost' -- POST /foo -- @ defEndpoint :: Endpoint -defEndpoint = Endpoint [] DocGET +defEndpoint = Endpoint [] HTTP.methodGet instance Hashable Endpoint @@ -155,6 +140,12 @@ data DocIntro = DocIntro , _introBody :: [String] -- ^ Each String is a paragraph. } deriving (Eq, Show) +-- | A type to represent Authentication information about an endpoint. +data DocAuthentication = DocAuthentication + { _authIntro :: String + , _authDataRequired :: String + } deriving (Eq, Ord, Show) + instance Ord DocIntro where compare = comparing _introTitle @@ -245,7 +236,8 @@ defResponse = Response -- You can tweak an 'Action' (like the default 'defAction') with these lenses -- to transform an action and add some information to it. data Action = Action - { _captures :: [DocCapture] -- type collected + user supplied info + { _authInfo :: [DocAuthentication] -- user supplied info + , _captures :: [DocCapture] -- type collected + user supplied info , _headers :: [Text] -- type collected , _params :: [DocQueryParam] -- type collected + user supplied info , _notes :: [DocNote] -- user supplied @@ -262,8 +254,8 @@ data Action = Action -- 'combineAction' to mush two together taking the response, body and content -- types from the very left. combineAction :: Action -> Action -> Action -Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ = - Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp +Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = + Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp -- Default 'Action'. Has no 'captures', no GET 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. @@ -283,6 +275,7 @@ defAction = [] [] [] + [] defResponse -- | Create an API that's comprised of a single endpoint. @@ -292,6 +285,7 @@ single :: Endpoint -> Action -> API single e a = API mempty (HM.singleton e a) -- gimme some lenses +makeLenses ''DocAuthentication makeLenses ''DocOptions makeLenses ''API makeLenses ''Endpoint @@ -469,7 +463,7 @@ instance AllHeaderSamples '[] where instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) => AllHeaderSamples (Header h l ': ls) where - allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) : + allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) : allHeaderToSample (Proxy :: Proxy ls) where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h) mkHeader (Just x) = (headerName, cs $ toByteString x) @@ -477,8 +471,8 @@ instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) -- | Synthesise a sample value of a type, encoded in the specified media types. sampleByteString - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(M.MediaType, ByteString)] sampleByteString ctypes@Proxy Proxy = @@ -487,8 +481,8 @@ sampleByteString ctypes@Proxy Proxy = -- | Synthesise a list of sample values of a particular type, encoded in the -- specified media types. sampleByteStrings - :: forall ctypes a. (ToSample a, IsNonEmpty ctypes, AllMimeRender ctypes a) - => Proxy ctypes + :: forall ct cts a. (ToSample a, AllMimeRender (ct ': cts) a) + => Proxy (ct ': cts) -> Proxy a -> [(Text, M.MediaType, ByteString)] sampleByteStrings ctypes@Proxy Proxy = @@ -519,6 +513,10 @@ class ToParam t where class ToCapture c where toCapture :: Proxy c -> DocCapture +-- | The class that helps us get documentation for authenticated endpoints +class ToAuthInfo a where + toAuthInfo :: Proxy a -> DocAuthentication + -- | Generate documentation in Markdown format for -- the given 'API'. markdown :: API -> String @@ -531,6 +529,7 @@ markdown api = unlines $ str : "" : notesStr (action ^. notes) ++ + authStr (action ^. authInfo) ++ capturesStr (action ^. captures) ++ headersStr (action ^. headers) ++ paramsStr (action ^. params) ++ @@ -538,7 +537,7 @@ markdown api = unlines $ responseStr (action ^. response) ++ [] - where str = "## " ++ show (endpoint^.method) + where str = "## " ++ BSC.unpack (endpoint^.method) ++ " " ++ showPath (endpoint^.path) introsStr :: [DocIntro] -> [String] @@ -563,6 +562,20 @@ markdown api = unlines $ "" : [] + + authStr :: [DocAuthentication] -> [String] + authStr auths = + let authIntros = mapped %~ view authIntro $ auths + clientInfos = mapped %~ view authDataRequired $ auths + in "#### Authentication": + "": + unlines authIntros : + "": + "Clients must supply the following data" : + unlines clientInfos : + "" : + [] + capturesStr :: [DocCapture] -> [String] capturesStr [] = [] capturesStr l = @@ -661,10 +674,7 @@ markdown api = unlines $ -- | The generated docs for @a ':<|>' b@ just appends the docs -- for @a@ with the docs for @b@. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ (HasDocs layout1, HasDocs layout2) => HasDocs (layout1 :<|> layout2) where @@ -692,70 +702,38 @@ instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) symP = Proxy :: Proxy sym -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Delete cts a) where +instance OVERLAPPABLE_ + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method) + => HasDocs (Verb method status (ct ': cts) a) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where endpoint' = endpoint & method .~ DocDELETE + where endpoint' = endpoint & method .~ method' action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t - t = Proxy :: Proxy cts + & response.respStatus .~ status + t = Proxy :: Proxy (ct ': cts) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Delete cts (Headers ls a)) where +instance OVERLAPPING_ + (ToSample a, AllMimeRender (ct ': cts) a, KnownNat status + , ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls)) + => HasDocs (Verb method status (ct ': cts) (Headers ls a)) where docsFor Proxy (endpoint, action) DocOptions{..} = single endpoint' action' - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocDELETE + where endpoint' = endpoint & method .~ method' action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) & response.respTypes .~ allMime t + & response.respStatus .~ status & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLe #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Get cts a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Get cts (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocGET - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) + hdrs = allHeaderToSample (Proxy :: Proxy ls) + method' = reflectMethod (Proxy :: Proxy method) + status = fromInteger $ natVal (Proxy :: Proxy status) p = Proxy :: Proxy a instance (KnownSymbol sym, HasDocs sublayout) @@ -765,77 +743,7 @@ instance (KnownSymbol sym, HasDocs sublayout) where sublayoutP = Proxy :: Proxy sublayout action' = over headers (|> headername) action - headername = pack $ symbolVal (Proxy :: Proxy sym) - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Post cts a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 201 - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a - , AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Post cts (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPOST - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 201 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - (ToSample a, IsNonEmpty cts, AllMimeRender cts a) - => HasDocs (Put cts a) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 200 - t = Proxy :: Proxy cts - p = Proxy :: Proxy a - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( ToSample a, IsNonEmpty cts, AllMimeRender cts a, - AllHeaderSamples ls , GetHeaders (HList ls) ) - => HasDocs (Put cts (Headers ls a)) where - docsFor Proxy (endpoint, action) DocOptions{..} = - single endpoint' action' - - where hdrs = allHeaderToSample (Proxy :: Proxy ls) - endpoint' = endpoint & method .~ DocPUT - action' = action & response.respBody .~ take _maxSamples (sampleByteStrings t p) - & response.respTypes .~ allMime t - & response.respStatus .~ 200 - & response.respHeaders .~ hdrs - t = Proxy :: Proxy cts - p = Proxy :: Proxy a + headername = T.pack $ symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) => HasDocs (QueryParam sym a :> sublayout) where @@ -877,8 +785,8 @@ instance HasDocs Raw where -- example data. However, there's no reason to believe that the instances of -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- both are even defined) for any particular type. -instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) - => HasDocs (ReqBody cts a :> sublayout) where +instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) + => HasDocs (ReqBody (ct ': cts) a :> sublayout) where docsFor Proxy (endpoint, action) = docsFor sublayoutP (endpoint, action') @@ -886,7 +794,7 @@ instance (ToSample a, IsNonEmpty cts, AllMimeRender cts a, HasDocs sublayout) where sublayoutP = Proxy :: Proxy sublayout action' = action & rqbody .~ sampleByteString t p & rqtypes .~ allMime t - t = Proxy :: Proxy cts + t = Proxy :: Proxy (ct ': cts) p = Proxy :: Proxy a instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where @@ -914,6 +822,16 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where docsFor Proxy ep = docsFor (Proxy :: Proxy sublayout) ep +instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where + docsFor Proxy = docsFor (Proxy :: Proxy sublayout) + +instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where + docsFor Proxy (endpoint, action) = + docsFor (Proxy :: Proxy sublayout) (endpoint, action') + where + authProxy = Proxy :: Proxy (BasicAuth realm usr) + action' = over authInfo (|> toAuthInfo authProxy) action + -- ToSample instances for simple types instance ToSample () instance ToSample Bool diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index 5375b0c3..018fd46b 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} @@ -18,8 +18,25 @@ import GHC.Generics import Test.Hspec import Servant.API +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Docs.Internal +-- * comprehensive api + +-- This declaration simply checks that all instances are in place. +_ = docs comprehensiveAPI + +instance ToParam (QueryParam "foo" Int) where + toParam = error "unused" +instance ToParam (QueryParams "foo" Int) where + toParam = error "unused" +instance ToParam (QueryFlag "foo") where + toParam = error "unused" +instance ToCapture (Capture "foo" Int) where + toCapture = error "unused" + +-- * specs + spec :: Spec spec = describe "Servant.Docs" $ do @@ -63,6 +80,7 @@ spec = describe "Servant.Docs" $ do , ("zwei, kaks, kaks",(TT2,UT2,UT2)) ] + where tests md = do it "mentions supported content-types" $ do @@ -71,17 +89,20 @@ spec = describe "Servant.Docs" $ do it "mentions status codes" $ do md `shouldContain` "Status code 200" - md `shouldContain` "Status code 201" - it "mentions methods" $ do - md `shouldContain` "POST" - md `shouldContain` "GET" + it "has methods as section headers" $ do + md `shouldContain` "## POST" + md `shouldContain` "## GET" + + it "mentions headers" $ do + md `shouldContain` "- This endpoint is sensitive to the value of the **X-Test** HTTP header." it "contains response samples" $ md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}" it "contains request body samples" $ md `shouldContain` "17" + -- * APIs data Datatype1 = Datatype1 { dt1field1 :: String @@ -104,6 +125,7 @@ instance MimeRender PlainText Int where type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 + :<|> Header "X-Test" Int :> Put '[JSON] Int data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq) diff --git a/servant-examples/Setup.hs b/servant-examples/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-examples/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs deleted file mode 100644 index ec152782..00000000 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - -import Data.Aeson -import Data.ByteString (ByteString) -import Data.Text (Text) -import GHC.Generics -import Network.Wai -import Network.Wai.Handler.Warp -import Servant -import Servant.Server.Internal - --- Pretty much stolen/adapted from --- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs - -type DBLookup = ByteString -> IO Bool - -isGoodCookie :: DBLookup -isGoodCookie = return . (== "good password") - -data AuthProtected - -instance HasServer rest => HasServer (AuthProtected :> rest) where - type ServerT (AuthProtected :> rest) m = ServerT rest m - - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy rest) $ addAcceptCheck subserver $ cookieCheck request - where - cookieCheck req = case lookup "Cookie" (requestHeaders req) of - Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" } - Just v -> do - authGranted <- isGoodCookie v - if authGranted - then return $ Route () - else return $ FailFatal err403 { errBody = "Invalid cookie" } - -type PrivateAPI = Get '[JSON] [PrivateData] - -type PublicAPI = Get '[JSON] [PublicData] - -type API = "private" :> AuthProtected :> PrivateAPI - :<|> PublicAPI - -newtype PrivateData = PrivateData { ssshhh :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PrivateData - -newtype PublicData = PublicData { somedata :: Text } - deriving (Eq, Show, Generic) - -instance ToJSON PublicData - -api :: Proxy API -api = Proxy - -server :: Server API -server = return prvdata :<|> return pubdata - - where prvdata = [PrivateData "this is a secret"] - pubdata = [PublicData "this is a public piece of data"] - -main :: IO () -main = run 8080 (serve api server) - -{- Sample session: -$ curl http://localhost:8080/ -[{"somedata":"this is a public piece of data"}] -$ curl http://localhost:8080/private -Missing auth header. -$ curl -H "Cookie: good password" http://localhost:8080/private -[{"ssshhh":"this is a secret"}] -$ curl -H "Cookie: bad password" http://localhost:8080/private -Invalid cookie. --} diff --git a/servant-examples/hackage/hackage.hs b/servant-examples/hackage/hackage.hs deleted file mode 100644 index 4d29b556..00000000 --- a/servant-examples/hackage/hackage.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -import Control.Applicative -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Aeson -import Data.Monoid -import Data.Proxy -import Data.Text (Text) -import GHC.Generics -import Network.HTTP.Client (Manager, defaultManagerSettings, - newManager) -import System.IO.Unsafe (unsafePerformIO) -import Servant.API -import Servant.Client - -import qualified Data.Text as T -import qualified Data.Text.IO as T - -type HackageAPI = - "users" :> Get '[JSON] [UserSummary] - :<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed - :<|> "packages" :> Get '[JSON] [Package] - -type Username = Text - -data UserSummary = UserSummary - { summaryUsername :: Username - , summaryUserid :: Int - } deriving (Eq, Show) - -instance FromJSON UserSummary where - parseJSON (Object o) = - UserSummary <$> o .: "username" - <*> o .: "userid" - - parseJSON _ = mzero - -type Group = Text - -data UserDetailed = UserDetailed - { username :: Username - , userid :: Int - , groups :: [Group] - } deriving (Eq, Show, Generic) - -instance FromJSON UserDetailed - -newtype Package = Package { packageName :: Text } - deriving (Eq, Show, Generic) - -instance FromJSON Package - -hackageAPI :: Proxy HackageAPI -hackageAPI = Proxy - - -{-# NOINLINE manager #-} -manager :: Manager -manager = unsafePerformIO $ newManager defaultManagerSettings - -getUsers :: ExceptT ServantError IO [UserSummary] -getUser :: Username -> ExceptT ServantError IO UserDetailed -getPackages :: ExceptT ServantError IO [Package] -getUsers :<|> getUser :<|> getPackages = - client hackageAPI (BaseUrl Http "hackage.haskell.org" 80 "") manager - -main :: IO () -main = print =<< uselessNumbers - -uselessNumbers :: IO (Either ServantError ()) -uselessNumbers = runExceptT $ do - users <- getUsers - liftIO . putStrLn $ show (length users) ++ " users" - - user <- liftIO $ do - putStrLn "Enter a valid hackage username" - T.getLine - userDetailed <- getUser user - liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages" - - packages <- getPackages - let monadPackages = filter (isMonadPackage . packageName) packages - liftIO . putStrLn $ show (length monadPackages) ++ " monad packages" - - where isMonadPackage = T.isInfixOf "monad" diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal deleted file mode 100644 index bd187106..00000000 --- a/servant-examples/servant-examples.cabal +++ /dev/null @@ -1,130 +0,0 @@ -name: servant-examples -version: 0.5 -synopsis: Example programs for servant -description: Example programs for servant, - showcasing solutions to common needs. -homepage: http://haskell-servant.github.io/ -license: BSD3 -license-file: LICENSE -author: Alp Mestanogullari -maintainer: alpmestan@gmail.com --- copyright: -category: Web -build-type: Simple -cabal-version: >=1.10 -bug-reports: http://github.com/haskell-servant/servant/issues -source-repository head - type: git - location: http://github.com/haskell-servant/servant.git - -executable tutorial - main-is: tutorial.hs - other-modules: T1, T2, T3, T4, T5, T6, T7, T8, T9, T10 - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing -fno-warn-orphans -fno-warn-unused-imports - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring - , directory - , http-types - , js-jquery - , lucid - , random - , servant == 0.5.* - , servant-docs == 0.5.* - , servant-js == 0.5.* - , servant-lucid == 0.5.* - , servant-server == 0.5.* - , text - , time - , transformers - , transformers-compat - , wai - , warp - hs-source-dirs: tutorial - default-language: Haskell2010 - -executable t8-main - main-is: t8-main.hs - other-modules: T3, T8 - hs-source-dirs: tutorial - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing - build-depends: - aeson - , base >= 4.7 && < 5 - , http-client > 0.4 && < 0.5 - , servant == 0.5.* - , servant-client == 0.5.* - , servant-server == 0.5.* - , transformers - , transformers-compat - , wai - -executable hackage - main-is: hackage.hs - build-depends: - aeson >= 0.8 - , base >=4.7 && < 5 - , http-client > 0.4 && < 0.5 - , servant == 0.5.* - , servant-client == 0.5.* - , text - , transformers - , transformers-compat - hs-source-dirs: hackage - default-language: Haskell2010 - -executable wai-middleware - main-is: wai-middleware.hs - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , servant == 0.5.* - , servant-server == 0.5.* - , text - , wai - , wai-extra - , warp - hs-source-dirs: wai-middleware - default-language: Haskell2010 - -executable auth-combinator - main-is: auth-combinator.hs - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring - , http-types - , servant == 0.5.* - , servant-server == 0.5.* - , text - , wai - , warp - hs-source-dirs: auth-combinator - default-language: Haskell2010 - -executable socket-io-chat - main-is: socket-io-chat.hs - ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing - other-modules: Chat - build-depends: - aeson >= 0.8 - , base >= 4.7 && < 5 - , bytestring - , http-types - , servant == 0.5.* - , servant-server == 0.5.* - , socket-io - , engine-io - , engine-io-wai - , text - , wai - , warp - , transformers - , stm - , mtl - ghc-options: -Wall -O2 -threaded - hs-source-dirs: socket-io-chat - default-language: Haskell2010 diff --git a/servant-examples/socket-io-chat/Chat.hs b/servant-examples/socket-io-chat/Chat.hs deleted file mode 100644 index 9f2faa92..00000000 --- a/servant-examples/socket-io-chat/Chat.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} - -module Chat (eioServer, ServerState (..)) where - -import Prelude hiding (mapM_) - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), pure) -#endif -import Control.Monad.State.Class (MonadState) -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson ((.=)) -import Data.Foldable (mapM_) - -import qualified Control.Concurrent.STM as STM -import qualified Data.Aeson as Aeson -import qualified Data.Text as Text -import qualified Network.SocketIO as SocketIO - - -data AddUser = AddUser Text.Text - -instance Aeson.FromJSON AddUser where - parseJSON = Aeson.withText "AddUser" $ pure . AddUser - - -data NumConnected = NumConnected !Int - -instance Aeson.ToJSON NumConnected where - toJSON (NumConnected n) = Aeson.object [ "numUsers" .= n] - - -data NewMessage = NewMessage Text.Text - -instance Aeson.FromJSON NewMessage where - parseJSON = Aeson.withText "NewMessage" $ pure . NewMessage - - -data Said = Said Text.Text Text.Text - -instance Aeson.ToJSON Said where - toJSON (Said username message) = Aeson.object - [ "username" .= username - , "message" .= message - ] - -data UserName = UserName Text.Text - -instance Aeson.ToJSON UserName where - toJSON (UserName un) = Aeson.object [ "username" .= un ] - - -data UserJoined = UserJoined Text.Text Int - -instance Aeson.ToJSON UserJoined where - toJSON (UserJoined un n) = Aeson.object - [ "username" .= un - , "numUsers" .= n - ] - - --------------------------------------------------------------------------------- -data ServerState = ServerState { ssNConnected :: STM.TVar Int } - ---server :: ServerState -> StateT SocketIO.RoutingTable Snap.Snap () -eioServer :: forall (m :: * -> *). (MonadState SocketIO.RoutingTable m, MonadIO m) => ServerState -> m () -eioServer state = do - userNameMVar <- liftIO STM.newEmptyTMVarIO - let forUserName m = liftIO (STM.atomically (STM.tryReadTMVar userNameMVar)) >>= mapM_ m - - SocketIO.on "new message" $ \(NewMessage message) -> - forUserName $ \userName -> - SocketIO.broadcast "new message" (Said userName message) - - SocketIO.on "add user" $ \(AddUser userName) -> do - n <- liftIO $ STM.atomically $ do - n <- (+ 1) <$> STM.readTVar (ssNConnected state) - STM.putTMVar userNameMVar userName - STM.writeTVar (ssNConnected state) n - return n - - SocketIO.emit "login" (NumConnected n) - SocketIO.broadcast "user joined" (UserJoined userName n) - - SocketIO.appendDisconnectHandler $ do - (n, mUserName) <- liftIO $ STM.atomically $ do - n <- (+ (-1)) <$> STM.readTVar (ssNConnected state) - mUserName <- STM.tryReadTMVar userNameMVar - STM.writeTVar (ssNConnected state) n - return (n, mUserName) - - case mUserName of - Nothing -> return () - Just userName -> - SocketIO.broadcast "user left" (UserJoined userName n) - - SocketIO.on "typing" $ - forUserName $ \userName -> - SocketIO.broadcast "typing" (UserName userName) - - SocketIO.on "stop typing" $ - forUserName $ \userName -> - SocketIO.broadcast "stop typing" (UserName userName) - diff --git a/servant-examples/socket-io-chat/resources/index.html b/servant-examples/socket-io-chat/resources/index.html deleted file mode 100644 index 92b055ff..00000000 --- a/servant-examples/socket-io-chat/resources/index.html +++ /dev/null @@ -1,28 +0,0 @@ - - - - - Socket.IO Chat Example - - - -
      -
    • -
      -
        -
        - -
        • - -
      - - - - - - diff --git a/servant-examples/socket-io-chat/resources/main.js b/servant-examples/socket-io-chat/resources/main.js deleted file mode 100644 index 08be0ad4..00000000 --- a/servant-examples/socket-io-chat/resources/main.js +++ /dev/null @@ -1,274 +0,0 @@ -$(function() { - var FADE_TIME = 150; // ms - var TYPING_TIMER_LENGTH = 400; // ms - var COLORS = [ - '#e21400', '#91580f', '#f8a700', '#f78b00', - '#58dc00', '#287b00', '#a8f07a', '#4ae8c4', - '#3b88eb', '#3824aa', '#a700ff', '#d300e7' - ]; - - // Initialize varibles - var $window = $(window); - var $usernameInput = $('.usernameInput'); // Input for username - var $messages = $('.messages'); // Messages area - var $inputMessage = $('.inputMessage'); // Input message input box - - var $loginPage = $('.login.page'); // The login page - var $chatPage = $('.chat.page'); // The chatroom page - - // Prompt for setting a username - var username; - var connected = false; - var typing = false; - var lastTypingTime; - var $currentInput = $usernameInput.focus(); - - var socket = io(); - - function addParticipantsMessage (data) { - var message = ''; - if (data.numUsers === 1) { - message += "there's 1 participant"; - } else { - message += "there're " + data.numUsers + " participants"; - } - log(message); - } - - // Sets the client's username - function setUsername () { - username = cleanInput($usernameInput.val().trim()); - - // If the username is valid - if (username) { - $loginPage.fadeOut(); - $chatPage.show(); - $loginPage.off('click'); - $currentInput = $inputMessage.focus(); - - // Tell the server your username - socket.emit('add user', username); - } - } - - // Sends a chat message - function sendMessage () { - var message = $inputMessage.val(); - // Prevent markup from being injected into the message - message = cleanInput(message); - // if there is a non-empty message and a socket connection - if (message && connected) { - $inputMessage.val(''); - addChatMessage({ - username: username, - message: message - }); - // tell server to execute 'new message' and send along one parameter - socket.emit('new message', message); - } - } - - // Log a message - function log (message, options) { - var $el = $('
    • ').addClass('log').text(message); - addMessageElement($el, options); - } - - // Adds the visual chat message to the message list - function addChatMessage (data, options) { - // Don't fade the message in if there is an 'X was typing' - var $typingMessages = getTypingMessages(data); - options = options || {}; - if ($typingMessages.length !== 0) { - options.fade = false; - $typingMessages.remove(); - } - - var $usernameDiv = $('') - .text(data.username) - .css('color', getUsernameColor(data.username)); - var $messageBodyDiv = $('') - .text(data.message); - - var typingClass = data.typing ? 'typing' : ''; - var $messageDiv = $('
    • ') - .data('username', data.username) - .addClass(typingClass) - .append($usernameDiv, $messageBodyDiv); - - addMessageElement($messageDiv, options); - } - - // Adds the visual chat typing message - function addChatTyping (data) { - data.typing = true; - data.message = 'is typing'; - addChatMessage(data); - } - - // Removes the visual chat typing message - function removeChatTyping (data) { - getTypingMessages(data).fadeOut(function () { - $(this).remove(); - }); - } - - // Adds a message element to the messages and scrolls to the bottom - // el - The element to add as a message - // options.fade - If the element should fade-in (default = true) - // options.prepend - If the element should prepend - // all other messages (default = false) - function addMessageElement (el, options) { - var $el = $(el); - - // Setup default options - if (!options) { - options = {}; - } - if (typeof options.fade === 'undefined') { - options.fade = true; - } - if (typeof options.prepend === 'undefined') { - options.prepend = false; - } - - // Apply options - if (options.fade) { - $el.hide().fadeIn(FADE_TIME); - } - if (options.prepend) { - $messages.prepend($el); - } else { - $messages.append($el); - } - $messages[0].scrollTop = $messages[0].scrollHeight; - } - - // Prevents input from having injected markup - function cleanInput (input) { - return $('
      ').text(input).text(); - } - - // Updates the typing event - function updateTyping () { - if (connected) { - if (!typing) { - typing = true; - socket.emit('typing'); - } - lastTypingTime = (new Date()).getTime(); - - setTimeout(function () { - var typingTimer = (new Date()).getTime(); - var timeDiff = typingTimer - lastTypingTime; - if (timeDiff >= TYPING_TIMER_LENGTH && typing) { - socket.emit('stop typing'); - typing = false; - } - }, TYPING_TIMER_LENGTH); - } - } - - // Gets the 'X is typing' messages of a user - function getTypingMessages (data) { - return $('.typing.message').filter(function (i) { - return $(this).data('username') === data.username; - }); - } - - // Gets the color of a username through our hash function - function getUsernameColor (username) { - // Compute hash code - var hash = 7; - for (var i = 0; i < username.length; i++) { - hash = username.charCodeAt(i) + (hash << 5) - hash; - } - // Calculate color - var index = Math.abs(hash % COLORS.length); - return COLORS[index]; - } - - // Keyboard events - - $window.keydown(function (event) { - // Auto-focus the current input when a key is typed - if (!(event.ctrlKey || event.metaKey || event.altKey)) { - $currentInput.focus(); - } - // When the client hits ENTER on their keyboard - if (event.which === 13) { - if (username) { - sendMessage(); - socket.emit('stop typing'); - typing = false; - } else { - setUsername(); - } - } - }); - - $inputMessage.on('input', function() { - updateTyping(); - }); - - // Click events - - // Focus input when clicking anywhere on login page - $loginPage.click(function () { - $currentInput.focus(); - }); - - // Focus input when clicking on the message input's border - $inputMessage.click(function () { - $inputMessage.focus(); - }); - - // Socket events - socket.on('connected', function (data) { - console.log('connected:', data); - }); - - // Socket events - socket.on('changes', function (data) { - console.log('changes:', data); - }); - - // Whenever the server emits 'login', log the login message - socket.on('login', function (data) { - connected = true; - // Display the welcome message - var message = "Welcome to Socket.IO Chat — "; - log(message, { - prepend: true - }); - addParticipantsMessage(data); - }); - - // Whenever the server emits 'new message', update the chat body - socket.on('new message', function (data) { - addChatMessage(data); - }); - - // Whenever the server emits 'user joined', log it in the chat body - socket.on('user joined', function (data) { - log(data.username + ' joined'); - addParticipantsMessage(data); - }); - - // Whenever the server emits 'user left', log it in the chat body - socket.on('user left', function (data) { - log(data.username + ' left'); - addParticipantsMessage(data); - removeChatTyping(data); - }); - - // Whenever the server emits 'typing', show the typing message - socket.on('typing', function (data) { - addChatTyping(data); - }); - - // Whenever the server emits 'stop typing', kill the typing message - socket.on('stop typing', function (data) { - removeChatTyping(data); - }); -}); diff --git a/servant-examples/socket-io-chat/resources/style.css b/servant-examples/socket-io-chat/resources/style.css deleted file mode 100644 index 62cbe093..00000000 --- a/servant-examples/socket-io-chat/resources/style.css +++ /dev/null @@ -1,150 +0,0 @@ -/* Fix user-agent */ - -* { - box-sizing: border-box; -} - -html { - font-weight: 300; - -webkit-font-smoothing: antialiased; -} - -html, input { - font-family: - "HelveticaNeue-Light", - "Helvetica Neue Light", - "Helvetica Neue", - Helvetica, - Arial, - "Lucida Grande", - sans-serif; -} - -html, body { - height: 100%; - margin: 0; - padding: 0; -} - -ul { - list-style: none; - word-wrap: break-word; -} - -/* Pages */ - -.pages { - height: 100%; - margin: 0; - padding: 0; - width: 100%; -} - -.page { - height: 100%; - position: absolute; - width: 100%; -} - -/* Login Page */ - -.login.page { - background-color: #000; -} - -.login.page .form { - height: 100px; - margin-top: -100px; - position: absolute; - - text-align: center; - top: 50%; - width: 100%; -} - -.login.page .form .usernameInput { - background-color: transparent; - border: none; - border-bottom: 2px solid #fff; - outline: none; - padding-bottom: 15px; - text-align: center; - width: 400px; -} - -.login.page .title { - font-size: 200%; -} - -.login.page .usernameInput { - font-size: 200%; - letter-spacing: 3px; -} - -.login.page .title, .login.page .usernameInput { - color: #fff; - font-weight: 100; -} - -/* Chat page */ - -.chat.page { - display: none; -} - -/* Font */ - -.messages { - font-size: 150%; -} - -.inputMessage { - font-size: 100%; -} - -.log { - color: gray; - font-size: 70%; - margin: 5px; - text-align: center; -} - -/* Messages */ - -.chatArea { - height: 100%; - padding-bottom: 60px; -} - -.messages { - height: 100%; - margin: 0; - overflow-y: scroll; - padding: 10px 20px 10px 20px; -} - -.message.typing .messageBody { - color: gray; -} - -.username { - float: left; - font-weight: 700; - overflow: hidden; - padding-right: 15px; - text-align: right; -} - -/* Input */ - -.inputMessage { - border: 10px solid #000; - bottom: 0; - height: 60px; - left: 0; - outline: none; - padding-left: 10px; - position: absolute; - right: 0; - width: 100%; -} diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs deleted file mode 100644 index 1250d8fe..00000000 --- a/servant-examples/socket-io-chat/socket-io-chat.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} - - -import Data.Monoid ((<>)) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Network.EngineIO.Wai -import Network.Wai -import Network.Wai.Handler.Warp (run) -import Servant - - -import qualified Control.Concurrent.STM as STM -import qualified Network.SocketIO as SocketIO - - -import Chat (ServerState (..), eioServer) - - -type API = "socket.io" :> Raw - :<|> Raw - - -api :: Proxy API -api = Proxy - - -server :: WaiMonad () -> Server API -server sHandler = socketIOHandler - :<|> serveDirectory "socket-io-chat/resources" - - where - socketIOHandler req respond = toWaiApplication sHandler req respond - - -app :: WaiMonad () -> Application -app sHandler = serve api $ server sHandler - -port :: Int -port = 3001 - - -main :: IO () -main = do - state <- ServerState <$> STM.newTVarIO 0 - sHandler <- SocketIO.initialize waiAPI (eioServer state) - putStrLn $ "Running on " <> show port - run port $ app sHandler - - diff --git a/servant-examples/tinc.yaml b/servant-examples/tinc.yaml deleted file mode 100644 index 10af8970..00000000 --- a/servant-examples/tinc.yaml +++ /dev/null @@ -1,15 +0,0 @@ -dependencies: - - name: servant - path: ../servant - - name: servant-server - path: ../servant-server - - name: servant-client - path: ../servant-client - - name: servant-js - path: ../servant-js - - name: servant-lucid - path: ../servant-lucid - - name: servant-docs - path: ../servant-docs - - name: servant-foreign - path: ../servant-foreign diff --git a/servant-examples/tutorial/T1.hs b/servant-examples/tutorial/T1.hs deleted file mode 100644 index 97bbecb8..00000000 --- a/servant-examples/tutorial/T1.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T1 where - -import Data.Aeson -import Data.Time.Calendar -import GHC.Generics -import Network.Wai -import Servant - -data User = User - { name :: String - , age :: Int - , email :: String - , registration_date :: Day - } deriving (Eq, Show, Generic) - -#if !MIN_VERSION_aeson(0,10,0) --- orphan ToJSON instance for Day. necessary to derive one for User -instance ToJSON Day where - -- display a day in YYYY-mm-dd format - toJSON d = toJSON (showGregorian d) -#endif - -instance ToJSON User - -type UserAPI = "users" :> Get '[JSON] [User] - -users :: [User] -users = - [ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) - , User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) - ] - -userAPI :: Proxy UserAPI -userAPI = Proxy - -server :: Server UserAPI -server = return users - -app :: Application -app = serve userAPI server diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs deleted file mode 100644 index be5da4cf..00000000 --- a/servant-examples/tutorial/T10.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T10 where - -import Data.ByteString.Lazy (ByteString) -import Data.Text.Lazy (pack) -import Data.Text.Lazy.Encoding (encodeUtf8) -import Network.HTTP.Types -import Network.Wai -import Servant -import Servant.Docs -import qualified T3 - -type DocsAPI = T3.API :<|> Raw - -instance ToCapture (Capture "x" Int) where - toCapture _ = DocCapture "x" "(integer) position on the x axis" - -instance ToCapture (Capture "y" Int) where - toCapture _ = DocCapture "y" "(integer) position on the y axis" - -instance ToSample T3.Position where - toSamples _ = singleSample (T3.Position 3 14) - -instance ToParam (QueryParam "name" String) where - toParam _ = - DocQueryParam "name" - ["Alp", "John Doe", "..."] - "Name of the person to say hello to." - Normal - -instance ToSample T3.HelloMessage where - toSamples _ = - [ ("When a value is provided for 'name'", T3.HelloMessage "Hello, Alp") - , ("When 'name' is not specified", T3.HelloMessage "Hello, anonymous coward") - ] - -ci :: T3.ClientInfo -ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"] - -instance ToSample T3.ClientInfo where - toSamples _ = singleSample ci - -instance ToSample T3.Email where - toSamples _ = singleSample (T3.emailForClient ci) - -api :: Proxy DocsAPI -api = Proxy - -docsBS :: ByteString -docsBS = encodeUtf8 - . pack - . markdown - $ docsWithIntros [intro] T3.api - - where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"] - -server :: Server DocsAPI -server = T3.server :<|> serveDocs - - where serveDocs _ respond = - respond $ responseLBS ok200 [plain] docsBS - - plain = ("Content-Type", "text/plain") - -app :: Application -app = serve api server diff --git a/servant-examples/tutorial/T2.hs b/servant-examples/tutorial/T2.hs deleted file mode 100644 index fc49d256..00000000 --- a/servant-examples/tutorial/T2.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T2 where - -import Data.Aeson -import Data.Time.Calendar -import GHC.Generics -import Network.Wai -import Servant - -data User = User - { name :: String - , age :: Int - , email :: String - , registration_date :: Day - } deriving (Eq, Show, Generic) - -#if !MIN_VERSION_aeson(0,10,0) --- orphan ToJSON instance for Day. necessary to derive one for User -instance ToJSON Day where - -- display a day in YYYY-mm-dd format - toJSON d = toJSON (showGregorian d) -#endif - -instance ToJSON User - -type UserAPI = "users" :> Get '[JSON] [User] - :<|> "albert" :> Get '[JSON] User - :<|> "isaac" :> Get '[JSON] User - -isaac :: User -isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1) - -albert :: User -albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1) - -users :: [User] -users = [isaac, albert] - -userAPI :: Proxy UserAPI -userAPI = Proxy - -server :: Server UserAPI -server = return users - :<|> return albert - :<|> return isaac - -app :: Application -app = serve userAPI server diff --git a/servant-examples/tutorial/T3.hs b/servant-examples/tutorial/T3.hs deleted file mode 100644 index 7b5bdeb3..00000000 --- a/servant-examples/tutorial/T3.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T3 where - -import Control.Monad.Trans.Except -import Data.Aeson -import Data.List -import GHC.Generics -import Network.Wai -import Servant - -data Position = Position - { x :: Int - , y :: Int - } deriving (Show, Generic) - -instance FromJSON Position -instance ToJSON Position - -newtype HelloMessage = HelloMessage { msg :: String } - deriving (Show, Generic) - -instance FromJSON HelloMessage -instance ToJSON HelloMessage - -data ClientInfo = ClientInfo - { name :: String - , email :: String - , age :: Int - , interested_in :: [String] - } deriving (Show, Generic) - -instance FromJSON ClientInfo -instance ToJSON ClientInfo - -data Email = Email - { from :: String - , to :: String - , subject :: String - , body :: String - } deriving (Show, Generic) - -instance FromJSON Email -instance ToJSON Email - -emailForClient :: ClientInfo -> Email -emailForClient c = Email from' to' subject' body' - - where from' = "great@company.com" - to' = email c - subject' = "Hey " ++ name c ++ ", we miss you!" - body' = "Hi " ++ name c ++ ",\n\n" - ++ "Since you've recently turned " ++ show (age c) - ++ ", have you checked out our latest " - ++ intercalate ", " (interested_in c) - ++ " products? Give us a visit!" - -type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position - :<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage - :<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email - -api :: Proxy API -api = Proxy - -server :: Server API -server = position - :<|> hello - :<|> marketing - - where position :: Int -> Int -> ExceptT ServantErr IO Position - position x y = return (Position x y) - - hello :: Maybe String -> ExceptT ServantErr IO HelloMessage - hello mname = return . HelloMessage $ case mname of - Nothing -> "Hello, anonymous coward" - Just n -> "Hello, " ++ n - - marketing :: ClientInfo -> ExceptT ServantErr IO Email - marketing clientinfo = return (emailForClient clientinfo) - -app :: Application -app = serve api server diff --git a/servant-examples/tutorial/T4.hs b/servant-examples/tutorial/T4.hs deleted file mode 100644 index 69cbf951..00000000 --- a/servant-examples/tutorial/T4.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T4 where - -import Data.Aeson -import Data.Foldable (foldMap) -import GHC.Generics -import Lucid -import Network.Wai -import Servant -import Servant.HTML.Lucid - -data Person = Person - { firstName :: String - , lastName :: String - , age :: Int - } deriving Generic -- for the JSON instance - --- JSON serialization -instance ToJSON Person - --- HTML serialization of a single person -instance ToHtml Person where - toHtml person = - tr_ $ do - td_ (toHtml $ firstName person) - td_ (toHtml $ lastName person) - td_ (toHtml . show $ age person) - - toHtmlRaw = toHtml - --- HTML serialization of a list of persons -instance ToHtml [Person] where - toHtml persons = table_ $ do - tr_ $ do - th_ "first name" - th_ "last name" - th_ "age" - - foldMap toHtml persons - - toHtmlRaw = toHtml - -persons :: [Person] -persons = - [ Person "Isaac" "Newton" 372 - , Person "Albert" "Einstein" 136 - ] - -type PersonAPI = "persons" :> Get '[JSON, HTML] [Person] - -personAPI :: Proxy PersonAPI -personAPI = Proxy - -server :: Server PersonAPI -server = return persons - -app :: Application -app = serve personAPI server diff --git a/servant-examples/tutorial/T5.hs b/servant-examples/tutorial/T5.hs deleted file mode 100644 index 3b18aedb..00000000 --- a/servant-examples/tutorial/T5.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T5 where - -import Control.Monad.IO.Class -import Control.Monad.Trans.Except -import Data.Aeson -import GHC.Generics -import Network.Wai -import Servant -import System.Directory - -type IOAPI = "myfile.txt" :> Get '[JSON] FileContent - -ioAPI :: Proxy IOAPI -ioAPI = Proxy - -newtype FileContent = FileContent - { content :: String } - deriving Generic - -instance ToJSON FileContent - -server :: Server IOAPI -server = do - exists <- liftIO (doesFileExist "myfile.txt") - if exists - then liftIO (readFile "myfile.txt") >>= return . FileContent - else throwE custom404Err - - where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." } - -app :: Application -app = serve ioAPI server diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs deleted file mode 100644 index 781bf703..00000000 --- a/servant-examples/tutorial/T6.hs +++ /dev/null @@ -1,18 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T6 where - -import Network.Wai -import Servant - -type API = "code" :> Raw - -api :: Proxy API -api = Proxy - -server :: Server API -server = serveDirectory "tutorial" - -app :: Application -app = serve api server diff --git a/servant-examples/tutorial/T7.hs b/servant-examples/tutorial/T7.hs deleted file mode 100644 index e0145caf..00000000 --- a/servant-examples/tutorial/T7.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T7 where - -import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader -import Network.Wai -import Servant - -type ReaderAPI = "a" :> Get '[JSON] Int - :<|> "b" :> Get '[JSON] String - -readerAPI :: Proxy ReaderAPI -readerAPI = Proxy - -readerServerT :: ServerT ReaderAPI (Reader String) -readerServerT = a :<|> b - - where a :: Reader String Int - a = return 1797 - - b :: Reader String String - b = ask - -readerServer :: Server ReaderAPI -readerServer = enter readerToEither readerServerT - - where readerToEither :: Reader String :~> ExceptT ServantErr IO - readerToEither = Nat $ \r -> return (runReader r "hi") - -app :: Application -app = serve readerAPI readerServer diff --git a/servant-examples/tutorial/T8.hs b/servant-examples/tutorial/T8.hs deleted file mode 100644 index 4e55df6f..00000000 --- a/servant-examples/tutorial/T8.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T8 where - -import Control.Monad.Trans.Except -import Network.HTTP.Client (Manager, defaultManagerSettings, - newManager) -import Servant -import Servant.Client -import System.IO.Unsafe (unsafePerformIO) - -import T3 - -position :: Int -- ^ value for "x" - -> Int -- ^ value for "y" - -> ExceptT ServantError IO Position - -hello :: Maybe String -- ^ an optional value for "name" - -> ExceptT ServantError IO HelloMessage - -marketing :: ClientInfo -- ^ value for the request body - -> ExceptT ServantError IO Email - -position :<|> hello :<|> marketing = client api baseUrl manager - -baseUrl :: BaseUrl -baseUrl = BaseUrl Http "localhost" 8081 "" - -{-# NOINLINE manager #-} -manager :: Manager -manager = unsafePerformIO $ newManager defaultManagerSettings - -queries :: ExceptT ServantError IO (Position, HelloMessage, Email) -queries = do - pos <- position 10 10 - msg <- hello (Just "servant") - em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) - return (pos, msg, em) - -run :: IO () -run = do - res <- runExceptT queries - case res of - Left err -> putStrLn $ "Error: " ++ show err - Right (pos, msg, em) -> do - print pos - print msg - print em diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs deleted file mode 100644 index 75dd0630..00000000 --- a/servant-examples/tutorial/T9.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -module T9 where - -import Control.Applicative -import Control.Monad.IO.Class -import Data.Aeson -import Data.Text (Text) -import GHC.Generics -import Network.Wai -import Servant -import Servant.JS -import System.Random - -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import qualified Language.Javascript.JQuery as JQ - -data Point = Point - { x :: Double - , y :: Double - } deriving Generic - -instance ToJSON Point - -randomPoint :: MonadIO m => m Point -randomPoint = liftIO . getStdRandom $ \g -> - let (rx, g') = randomR (-1, 1) g - (ry, g'') = randomR (-1, 1) g' - in (Point rx ry, g'') - -data Search a = Search - { query :: Text - , results :: [a] - } deriving Generic - -mkSearch :: Text -> [a] -> Search a -mkSearch = Search - -instance ToJSON a => ToJSON (Search a) - -data Book = Book - { author :: Text - , title :: Text - , year :: Int - } deriving Generic - -instance ToJSON Book - -book :: Text -> Text -> Int -> Book -book = Book - -books :: [Book] -books = - [ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000 - , book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008 - , book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011 - , book "Graham Hutton" "Programming in Haskell" 2007 - , book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013 - , book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998 - ] - -searchBook :: Monad m => Maybe Text -> m (Search Book) -searchBook Nothing = return (mkSearch "" books) -searchBook (Just q) = return (mkSearch q books') - - where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b) - || q' `T.isInfixOf` T.toLower (title b) - ) - books - q' = T.toLower q - -type API = "point" :> Get '[JSON] Point - :<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book) - -type API' = API :<|> Raw - -api :: Proxy API -api = Proxy - -api' :: Proxy API' -api' = Proxy - -server :: Server API -server = randomPoint - :<|> searchBook - -server' :: Server API' -server' = server - :<|> serveDirectory "tutorial/t9" - -apiJS :: Text -apiJS = jsForAPI api jquery - -writeJSFiles :: IO () -writeJSFiles = do - TIO.writeFile "tutorial/t9/api.js" apiJS - jq <- TIO.readFile =<< JQ.file - TIO.writeFile "tutorial/t9/jq.js" jq - -app :: Application -app = serve api' server' diff --git a/servant-examples/tutorial/t8-main.hs b/servant-examples/tutorial/t8-main.hs deleted file mode 100644 index b0e4979d..00000000 --- a/servant-examples/tutorial/t8-main.hs +++ /dev/null @@ -1,4 +0,0 @@ -import T8 - -main :: IO () -main = run diff --git a/servant-examples/tutorial/tutorial.hs b/servant-examples/tutorial/tutorial.hs deleted file mode 100644 index 32dc4c06..00000000 --- a/servant-examples/tutorial/tutorial.hs +++ /dev/null @@ -1,39 +0,0 @@ -import Network.Wai -import Network.Wai.Handler.Warp -import System.Environment - -import qualified T1 -import qualified T10 -import qualified T2 -import qualified T3 -import qualified T4 -import qualified T5 -import qualified T6 -import qualified T7 -import qualified T9 - -app :: String -> (Application -> IO ()) -> IO () -app n f = case n of - "1" -> f T1.app - "2" -> f T2.app - "3" -> f T3.app - "4" -> f T4.app - "5" -> f T5.app - "6" -> f T6.app - "7" -> f T7.app - "8" -> f T3.app - "9" -> T9.writeJSFiles >> f T9.app - "10" -> f T10.app - _ -> usage - -main :: IO () -main = do - args <- getArgs - case args of - [n] -> app n (run 8081) - _ -> usage - -usage :: IO () -usage = do - putStrLn "Usage:\t tutorial N" - putStrLn "\t\twhere N is the number of the example you want to run." diff --git a/servant-examples/wai-middleware/wai-middleware.hs b/servant-examples/wai-middleware/wai-middleware.hs deleted file mode 100644 index d625d092..00000000 --- a/servant-examples/wai-middleware/wai-middleware.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -import Data.Aeson -import Data.Text -import GHC.Generics -import Network.Wai -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.RequestLogger -import Servant - -data Product = Product - { name :: Text - , brand :: Text - , current_price_eur :: Double - , available :: Bool - } deriving (Eq, Show, Generic) - -instance ToJSON Product - -products :: [Product] -products = [p1, p2] - - where p1 = Product "Haskell laptop sticker" - "GHC Industries" - 2.50 - True - - p2 = Product "Foldable USB drive" - "Well-Typed" - 13.99 - False - -type SimpleAPI = Get '[JSON] [Product] - -simpleAPI :: Proxy SimpleAPI -simpleAPI = Proxy - -server :: Server SimpleAPI -server = return products - --- logStdout :: Middleware --- i.e, logStdout :: Application -> Application --- serve :: Proxy api -> Server api -> Application --- so applying a middleware is really as simple as --- applying a function to the result of 'serve' -app :: Application -app = logStdout (serve simpleAPI server) - -main :: IO () -main = run 8080 app diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 5d242065..75628b79 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -1,4 +1,5 @@ -HEAD +0.5 ----- * Use the `text` package instead of `String`. * Extract javascript-oblivious types and helpers to *servant-foreign* +* Typed-languages support diff --git a/servant-foreign/LICENSE b/servant-foreign/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-foreign/LICENSE +++ b/servant-foreign/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-foreign/include/overlapping-compat.h b/servant-foreign/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-foreign/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 0ec296ae..45673dbc 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -1,5 +1,5 @@ name: servant-foreign -version: 0.5 +version: 0.6 synopsis: Helpers for generating clients for servant APIs in any programming language description: Helper types and functions for generating client functions for servant APIs in any programming language @@ -11,13 +11,14 @@ description: license: BSD3 license-file: LICENSE -author: Denis Redozubov, Maksymilian Owsianny -maintainer: denis.redozubov@gmail.com -copyright: 2015 Denis Redozubov, Alp Mestanogullari +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head @@ -25,24 +26,55 @@ source-repository head location: http://github.com/haskell-servant/servant.git library - exposed-modules: Servant.Foreign, Servant.Foreign.Internal - build-depends: base == 4.* - , lens == 4.* - , servant == 0.5.* - , text >= 1.2 && < 1.3 + exposed-modules: Servant.Foreign + , Servant.Foreign.Internal + , Servant.Foreign.Inflections + build-depends: base == 4.* + , lens == 4.* + , servant == 0.6.* + , text >= 1.2 && < 1.3 + , http-types hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include + default-extensions: CPP + , ConstraintKinds + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ScopedTypeVariables + , StandaloneDeriving + , TemplateHaskell + , TypeFamilies + , TypeOperators + , UndecidableInstances + , OverloadedStrings + , PolyKinds test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test ghc-options: -Wall + include-dirs: include main-is: Spec.hs - other-modules: - Servant.ForeignSpec + other-modules: Servant.ForeignSpec build-depends: base , hspec >= 2.1.8 , servant-foreign default-language: Haskell2010 + default-extensions: ConstraintKinds + , DataKinds + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , ScopedTypeVariables + , TypeFamilies + , TypeOperators + , UndecidableInstances + , OverloadedStrings + , PolyKinds diff --git a/servant-foreign/src/Servant/Foreign.hs b/servant-foreign/src/Servant/Foreign.hs index 5054e69f..e2d212b6 100644 --- a/servant-foreign/src/Servant/Foreign.hs +++ b/servant-foreign/src/Servant/Foreign.hs @@ -1,39 +1,56 @@ -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages. module Servant.Foreign - ( HasForeign(..) - , HasForeignType(..) + ( ArgType(..) + , HeaderArg(..) + , QueryArg(..) + , Req(..) , Segment(..) , SegmentType(..) - , FunctionName - , QueryArg(..) - , HeaderArg(..) - , ArgType(..) - , Req - , captureArg - , defReq - , concatCase - , snakeCase - , camelCase - -- lenses - , argType + , Url(..) + -- aliases + , Path + , Arg(..) + , FunctionName(..) + , PathSegment(..) + -- lenses , argName - , isCapture - , funcName - , path + , argType + , argPath , reqUrl - , reqBody - , reqHeaders , reqMethod + , reqHeaders + , reqBody , reqReturnType - , segment + , reqFuncName + , path , queryStr - , listFromAPI + , queryArgName + , queryArgType + , headerArg + -- prisms + , _PathSegment + , _HeaderArg + , _ReplaceHeaderArg + , _Static + , _Cap + , _Normal + , _Flag + , _List + -- rest of it + , HasForeign(..) + , HasForeignType(..) , GenerateList(..) , NoTypes - -- re-exports + , captureArg + , isCapture + , defReq + , listFromAPI + -- re-exports , module Servant.API + , module Servant.Foreign.Inflections ) where import Servant.API import Servant.Foreign.Internal +import Servant.Foreign.Inflections diff --git a/servant-foreign/src/Servant/Foreign/Inflections.hs b/servant-foreign/src/Servant/Foreign/Inflections.hs new file mode 100644 index 00000000..759d04a0 --- /dev/null +++ b/servant-foreign/src/Servant/Foreign/Inflections.hs @@ -0,0 +1,45 @@ +module Servant.Foreign.Inflections + ( concatCase + , snakeCase + , camelCase + -- lenses + , concatCaseL + , snakeCaseL + , camelCaseL + ) where + + +import Control.Lens hiding (cons) +import qualified Data.Char as C +import Data.Monoid +import Data.Text hiding (map) +import Prelude hiding (head, tail) +import Servant.Foreign.Internal + +concatCaseL :: Getter FunctionName Text +concatCaseL = _FunctionName . to mconcat + +-- | Function name builder that simply concat each part together +concatCase :: FunctionName -> Text +concatCase = view concatCaseL + +snakeCaseL :: Getter FunctionName Text +snakeCaseL = _FunctionName . to (intercalate "_") + +-- | Function name builder using the snake_case convention. +-- each part is separated by a single underscore character. +snakeCase :: FunctionName -> Text +snakeCase = view snakeCaseL + +camelCaseL :: Getter FunctionName Text +camelCaseL = _FunctionName . to (convert . map (replace "-" "")) + where + convert [] = "" + convert (p:ps) = mconcat $ p : map capitalize ps + capitalize "" = "" + capitalize name = C.toUpper (head name) `cons` tail name + +-- | Function name builder using the CamelCase convention. +-- each part begins with an upper case character. +camelCase :: FunctionName -> Text +camelCase = view camelCaseL diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 27f0e411..72f24116 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -1,117 +1,138 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} #if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE NullaryTypeClasses #-} +{-# LANGUAGE NullaryTypeClasses #-} #endif -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE OverloadedStrings #-} -- | Generalizes all the data needed to make code generation work with -- arbitrary programming languages. module Servant.Foreign.Internal where -import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) -import qualified Data.Char as C +import Control.Lens hiding (cons, List) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif import Data.Proxy +import Data.String import Data.Text -import GHC.Exts (Constraint) +import Data.Text.Encoding (decodeUtf8) +import GHC.Exts (Constraint) import GHC.TypeLits -import Prelude hiding (concat) +import qualified Network.HTTP.Types as HTTP +import Prelude hiding (concat) import Servant.API --- | Function name builder that simply concat each part together -concatCase :: FunctionName -> Text -concatCase = concat --- | Function name builder using the snake_case convention. --- each part is separated by a single underscore character. -snakeCase :: FunctionName -> Text -snakeCase = intercalate "_" +newtype FunctionName = FunctionName { unFunctionName :: [Text] } + deriving (Show, Eq, Monoid) --- | Function name builder using the CamelCase convention. --- each part begins with an upper case character. -camelCase :: FunctionName -> Text -camelCase = camelCase' . Prelude.map (replace "-" "") - where camelCase' [] = "" - camelCase' (p:ps) = concat $ p : Prelude.map capitalize ps - capitalize "" = "" - capitalize name = C.toUpper (Data.Text.head name) `cons` Data.Text.tail name +makePrisms ''FunctionName -type ForeignType = Text -type Arg = (Text, ForeignType) +newtype PathSegment = PathSegment { unPathSegment :: Text } + deriving (Show, Eq, IsString, Monoid) -newtype Segment = Segment { _segment :: SegmentType } - deriving (Eq, Show) +makePrisms ''PathSegment -data SegmentType = Static Text -- ^ a static path segment. like "/foo" - | Cap Arg -- ^ a capture. like "/:userid" - deriving (Eq, Show) +data Arg f = Arg + { _argName :: PathSegment + , _argType :: f } -type Path = [Segment] +deriving instance Eq f => Eq (Arg f) +deriving instance Show f => Show (Arg f) -data ArgType = - Normal +makeLenses ''Arg + +argPath :: Getter (Arg f) Text +argPath = argName . _PathSegment + +data SegmentType f + = Static PathSegment + -- ^ a static path segment. like "/foo" + | Cap (Arg f) + -- ^ a capture. like "/:userid" + +deriving instance Eq f => Eq (SegmentType f) +deriving instance Show f => Show (SegmentType f) + +makePrisms ''SegmentType + +newtype Segment f = Segment { unSegment :: SegmentType f } + +deriving instance Eq f => Eq (Segment f) +deriving instance Show f => Show (Segment f) + +makePrisms ''Segment + +isCapture :: Segment f -> Bool +isCapture (Segment (Cap _)) = True +isCapture _ = False + +captureArg :: Segment f -> Arg f +captureArg (Segment (Cap s)) = s +captureArg _ = error "captureArg called on non capture" + +type Path f = [Segment f] + +data ArgType + = Normal | Flag | List deriving (Eq, Show) -data QueryArg = QueryArg - { _argName :: Arg - , _argType :: ArgType - } deriving (Eq, Show) +makePrisms ''ArgType -data HeaderArg = HeaderArg - { headerArg :: Arg - } - | ReplaceHeaderArg - { headerArg :: Arg - , headerPattern :: Text - } deriving (Eq, Show) +data QueryArg f = QueryArg + { _queryArgName :: Arg f + , _queryArgType :: ArgType + } - -data Url = Url - { _path :: Path - , _queryStr :: [QueryArg] - } deriving (Eq, Show) - -defUrl :: Url -defUrl = Url [] [] - -type FunctionName = [Text] -type Method = Text - -data Req = Req - { _reqUrl :: Url - , _reqMethod :: Method - , _reqHeaders :: [HeaderArg] - , _reqBody :: Maybe ForeignType - , _reqReturnType :: ForeignType - , _funcName :: FunctionName - } deriving (Eq, Show) +deriving instance Eq f => Eq (QueryArg f) +deriving instance Show f => Show (QueryArg f) makeLenses ''QueryArg -makeLenses ''Segment + +data HeaderArg f = HeaderArg + { _headerArg :: Arg f } + | ReplaceHeaderArg + { _headerArg :: Arg f + , _headerPattern :: Text + } + +deriving instance Eq f => Eq (HeaderArg f) +deriving instance Show f => Show (HeaderArg f) + +makeLenses ''HeaderArg + +makePrisms ''HeaderArg + +data Url f = Url + { _path :: Path f + , _queryStr :: [QueryArg f] + } + +deriving instance Eq f => Eq (Url f) +deriving instance Show f => Show (Url f) + +defUrl :: Url f +defUrl = Url [] [] + makeLenses ''Url + +data Req f = Req + { _reqUrl :: Url f + , _reqMethod :: HTTP.Method + , _reqHeaders :: [HeaderArg f] + , _reqBody :: Maybe f + , _reqReturnType :: Maybe f + , _reqFuncName :: FunctionName + } + +deriving instance Eq f => Eq (Req f) +deriving instance Show f => Show (Req f) + makeLenses ''Req -isCapture :: Segment -> Bool -isCapture (Segment (Cap _)) = True -isCapture _ = False - -captureArg :: Segment -> Arg -captureArg (Segment (Cap s)) = s -captureArg _ = error "captureArg called on non capture" - -defReq :: Req -defReq = Req defUrl "GET" [] Nothing "" [] +defReq :: Req ftype +defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) -- | To be used exclusively as a "negative" return type/constraint -- by @'Elem`@ type family. @@ -124,226 +145,218 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where -- | 'HasForeignType' maps Haskell types with types in the target -- language of your backend. For example, let's say you're --- implementing a backend to some language __X__: +-- implementing a backend to some language __X__, and you want +-- a Text representation of each input/output type mentioned in the API: -- -- > -- First you need to create a dummy type to parametrize your -- > -- instances. -- > data LangX -- > -- > -- Otherwise you define instances for the types you need --- > instance HasForeignType LangX Int where --- > typeFor _ _ = "intX" +-- > instance HasForeignType LangX Text Int where +-- > typeFor _ _ _ = "intX" -- > -- > -- Or for example in case of lists --- > instance HasForeignType LangX a => HasForeignType LangX [a] where --- > typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) +-- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where +-- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) -- -- Finally to generate list of information about all the endpoints for -- an API you create a function of a form: -- --- > getEndpoints :: (HasForeign LangX api, GenerateList (Foreign api)) --- > => Proxy api -> [Req] --- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) api +-- > getEndpoints :: (HasForeign LangX Text api, GenerateList Text (Foreign Text api)) +-- > => Proxy api -> [Req Text] +-- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy Text) api -- -- > -- If language __X__ is dynamically typed then you can use --- > -- a predefined NoTypes parameter --- > getEndpoints :: (HasForeign NoTypes api, GenerateList (Foreign api)) --- > => Proxy api -> [Req] --- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) api +-- > -- a predefined NoTypes parameter with the () output type: +-- +-- > getEndpoints :: (HasForeign NoTypes () api, GenerateList Text (Foreign () api)) +-- > => Proxy api -> [Req ()] +-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) api -- > -- -class HasForeignType lang a where - typeFor :: Proxy lang -> Proxy a -> ForeignType +class HasForeignType lang ftype a where + typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype data NoTypes -instance HasForeignType NoTypes a where - typeFor _ _ = empty +instance HasForeignType NoTypes () ftype where + typeFor _ _ _ = () -class HasForeign lang (layout :: *) where - type Foreign layout :: * - foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout +class HasForeign lang ftype (layout :: *) where + type Foreign ftype layout :: * + foreignFor :: Proxy lang -> Proxy ftype -> Proxy layout -> Req ftype -> Foreign ftype layout -instance (HasForeign lang a, HasForeign lang b) - => HasForeign lang (a :<|> b) where - type Foreign (a :<|> b) = Foreign a :<|> Foreign b +instance (HasForeign lang ftype a, HasForeign lang ftype b) + => HasForeign lang ftype (a :<|> b) where + type Foreign ftype (a :<|> b) = Foreign ftype a :<|> Foreign ftype b - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy a) req - :<|> foreignFor lang (Proxy :: Proxy b) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy a) req + :<|> foreignFor lang ftype (Proxy :: Proxy b) req -instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (Capture sym a :> sublayout) where - type Foreign (Capture sym a :> sublayout) = Foreign sublayout - - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Cap arg)] - & funcName %~ (++ ["by", str]) +instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype sublayout) + => HasForeign lang ftype (Capture sym t :> sublayout) where + type Foreign ftype (Capture sym a :> sublayout) = Foreign ftype sublayout + foreignFor lang Proxy Proxy req = + foreignFor lang Proxy (Proxy :: Proxy sublayout) $ + req & reqUrl . path <>~ [Segment (Cap arg)] + & reqFuncName . _FunctionName %~ (++ ["by", str]) where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy t) + arg = Arg + { _argName = PathSegment str + , _argType = ftype } -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Delete list a) where - type Foreign (Delete list a) = Req +instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method) + => HasForeign lang ftype (Verb method status list a) where + type Foreign ftype (Verb method status list a) = Req ftype - foreignFor lang Proxy req = - req & funcName %~ ("delete" :) - & reqMethod .~ "DELETE" - & reqReturnType .~ retType + foreignFor lang Proxy Proxy req = + req & reqFuncName . _FunctionName %~ (methodLC :) + & reqMethod .~ method + & reqReturnType .~ Just retType where - retType = typeFor lang (Proxy :: Proxy a) + retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) + method = reflectMethod (Proxy :: Proxy method) + methodLC = toLower $ decodeUtf8 method -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Get list a) where - type Foreign (Get list a) = Req +instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout) + => HasForeign lang ftype (Header sym a :> sublayout) where + type Foreign ftype (Header sym a :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - req & funcName %~ ("get" :) - & reqMethod .~ "GET" - & reqReturnType .~ retType + foreignFor lang Proxy Proxy req = + foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg] where - retType = typeFor lang (Proxy :: Proxy a) + hname = pack . symbolVal $ (Proxy :: Proxy sym) + arg = Arg + { _argName = PathSegment hname + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } + subP = Proxy :: Proxy sublayout -instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (Header sym a :> sublayout) where - type Foreign (Header sym a :> sublayout) = Foreign sublayout +instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype sublayout) + => HasForeign lang ftype (QueryParam sym a :> sublayout) where + type Foreign ftype (QueryParam sym a :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang subP $ req - & reqHeaders <>~ [HeaderArg arg] - - where - hname = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (hname, typeFor lang (Proxy :: Proxy a)) - subP = Proxy :: Proxy sublayout - -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Post list a) where - type Foreign (Post list a) = Req - - foreignFor lang Proxy req = - req & funcName %~ ("post" :) - & reqMethod .~ "POST" - & reqReturnType .~ retType - where - retType = typeFor lang (Proxy :: Proxy a) - -instance (Elem JSON list, HasForeignType lang a) - => HasForeign lang (Put list a) where - type Foreign (Put list a) = Req - - foreignFor lang Proxy req = - req & funcName %~ ("put" :) - & reqMethod .~ "PUT" - & reqReturnType .~ retType - where - retType = typeFor lang (Proxy :: Proxy a) - -instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (QueryParam sym a :> sublayout) where - type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout - - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Normal] - where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = Arg + { _argName = PathSegment str + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) } -instance (KnownSymbol sym, HasForeignType lang [a], HasForeign lang sublayout) - => HasForeign lang (QueryParams sym a :> sublayout) where - type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout - - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ +instance + (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype sublayout) + => HasForeign lang ftype (QueryParams sym a :> sublayout) where + type Foreign ftype (QueryParams sym a :> sublayout) = Foreign ftype sublayout + foreignFor lang Proxy Proxy req = + foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg List] - where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy [a])) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = Arg + { _argName = PathSegment str + , _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [a]) } -instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang sublayout) - => HasForeign lang (QueryFlag sym :> sublayout) where - type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout +instance + (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype sublayout) + => HasForeign lang ftype (QueryFlag sym :> sublayout) where + type Foreign ftype (QueryFlag sym :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) $ req & reqUrl.queryStr <>~ [QueryArg arg Flag] - where - str = pack . symbolVal $ (Proxy :: Proxy sym) - arg = (str, typeFor lang (Proxy :: Proxy a)) + str = pack . symbolVal $ (Proxy :: Proxy sym) + arg = Arg + { _argName = PathSegment str + , _argType = typeFor lang ftype (Proxy :: Proxy Bool) } -instance HasForeign lang Raw where - type Foreign Raw = Method -> Req +instance HasForeign lang ftype Raw where + type Foreign ftype Raw = HTTP.Method -> Req ftype - foreignFor _ Proxy req method = - req & funcName %~ ((toLower method) :) + foreignFor _ Proxy Proxy req method = + req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :) & reqMethod .~ method -instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) - => HasForeign lang (ReqBody list a :> sublayout) where - type Foreign (ReqBody list a :> sublayout) = Foreign sublayout +instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype sublayout) + => HasForeign lang ftype (ReqBody list a :> sublayout) where + type Foreign ftype (ReqBody list a :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqBody .~ (Just $ typeFor lang (Proxy :: Proxy a)) + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a)) -instance (KnownSymbol path, HasForeign lang sublayout) - => HasForeign lang (path :> sublayout) where - type Foreign (path :> sublayout) = Foreign sublayout - - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqUrl.path <>~ [Segment (Static str)] - & funcName %~ (++ [str]) +instance (KnownSymbol path, HasForeign lang ftype sublayout) + => HasForeign lang ftype (path :> sublayout) where + type Foreign ftype (path :> sublayout) = Foreign ftype sublayout + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqUrl . path <>~ [Segment (Static (PathSegment str))] + & reqFuncName . _FunctionName %~ (++ [str]) where - str = Data.Text.map (\c -> if c == '.' then '_' else c) - . pack . symbolVal $ (Proxy :: Proxy path) + str = + Data.Text.map (\c -> if c == '.' then '_' else c) + . pack . symbolVal $ (Proxy :: Proxy path) -instance HasForeign lang sublayout => HasForeign lang (RemoteHost :> sublayout) where - type Foreign (RemoteHost :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout + => HasForeign lang ftype (RemoteHost :> sublayout) where + type Foreign ftype (RemoteHost :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout => HasForeign lang (IsSecure :> sublayout) where - type Foreign (IsSecure :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout + => HasForeign lang ftype (IsSecure :> sublayout) where + type Foreign ftype (IsSecure :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where - type Foreign (Vault :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout => HasForeign lang ftype (Vault :> sublayout) where + type Foreign ftype (Vault :> sublayout) = Foreign ftype sublayout - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where - type Foreign (HttpVersion :> sublayout) = Foreign sublayout +instance HasForeign lang ftype sublayout => + HasForeign lang ftype (WithNamedContext name context sublayout) where - foreignFor lang Proxy req = - foreignFor lang (Proxy :: Proxy sublayout) req + type Foreign ftype (WithNamedContext name context sublayout) = Foreign ftype sublayout + + foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy sublayout) + +instance HasForeign lang ftype sublayout + => HasForeign lang ftype (HttpVersion :> sublayout) where + type Foreign ftype (HttpVersion :> sublayout) = Foreign ftype sublayout + + foreignFor lang ftype Proxy req = + foreignFor lang ftype (Proxy :: Proxy sublayout) req -- | Utility class used by 'listFromAPI' which computes -- the data needed to generate a function for each endpoint -- and hands it all back in a list. -class GenerateList reqs where - generateList :: reqs -> [Req] +class GenerateList ftype reqs where + generateList :: reqs -> [Req ftype] -instance GenerateList Req where +instance GenerateList ftype (Req ftype) where generateList r = [r] -instance (GenerateList start, GenerateList rest) => GenerateList (start :<|> rest) where +instance (GenerateList ftype start, GenerateList ftype rest) + => GenerateList ftype (start :<|> rest) where generateList (start :<|> rest) = (generateList start) ++ (generateList rest) -- | Generate the necessary data for codegen as a list, each 'Req' -- describing one endpoint from your API type. -listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req] -listFromAPI lang p = generateList (foreignFor lang p defReq) - +listFromAPI + :: (HasForeign lang ftype api, GenerateList ftype (Foreign ftype api)) + => Proxy lang + -> Proxy ftype + -> Proxy api + -> [Req ftype] +listFromAPI lang ftype p = generateList (foreignFor lang ftype p defReq) diff --git a/servant-foreign/test/Servant/ForeignSpec.hs b/servant-foreign/test/Servant/ForeignSpec.hs index a5bad431..0a762e1c 100644 --- a/servant-foreign/test/Servant/ForeignSpec.hs +++ b/servant-foreign/test/Servant/ForeignSpec.hs @@ -1,22 +1,11 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -#endif +{-# LANGUAGE CPP #-} +#include "overlapping-compat.h" module Servant.ForeignSpec where import Data.Monoid ((<>)) import Data.Proxy import Servant.Foreign -import Servant.Foreign.Internal import Test.Hspec @@ -28,23 +17,29 @@ spec = describe "Servant.Foreign" $ do camelCaseSpec :: Spec camelCaseSpec = describe "camelCase" $ do it "converts FunctionNames to camelCase" $ do - camelCase ["post", "counter", "inc"] `shouldBe` "postCounterInc" - camelCase ["get", "hyphen-ated", "counter"] `shouldBe` "getHyphenatedCounter" + camelCase (FunctionName ["post", "counter", "inc"]) + `shouldBe` "postCounterInc" + camelCase (FunctionName ["get", "hyphen-ated", "counter"]) + `shouldBe` "getHyphenatedCounter" ---------------------------------------------------------------------- data LangX -instance HasForeignType LangX () where - typeFor _ _ = "voidX" -instance HasForeignType LangX Int where - typeFor _ _ = "intX" -instance HasForeignType LangX Bool where - typeFor _ _ = "boolX" -instance {-# Overlapping #-} HasForeignType LangX String where - typeFor _ _ = "stringX" -instance {-# Overlappable #-} HasForeignType LangX a => HasForeignType LangX [a] where - typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) +instance HasForeignType LangX String () where + typeFor _ _ _ = "voidX" + +instance HasForeignType LangX String Int where + typeFor _ _ _ = "intX" + +instance HasForeignType LangX String Bool where + typeFor _ _ _ = "boolX" + +instance OVERLAPPING_ HasForeignType LangX String String where + typeFor _ _ _ = "stringX" + +instance OVERLAPPABLE_ HasForeignType LangX String a => HasForeignType LangX String [a] where + typeFor lang ftype _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a) type TestApi = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int @@ -52,63 +47,62 @@ type TestApi :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] () :<|> "test" :> Capture "id" Int :> Delete '[JSON] () -testApi :: [Req] -testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi) +testApi :: [Req String] +testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi) listFromAPISpec :: Spec listFromAPISpec = describe "listFromAPI" $ do - it "generates 4 endpoints for TestApi" $ do - length testApi `shouldBe` 4 + it "generates 4 endpoints for TestApi" $ do + length testApi `shouldBe` 4 - let [getReq, postReq, putReq, deleteReq] = testApi + let [getReq, postReq, putReq, deleteReq] = testApi - it "collects all info for get request" $ do - shouldBe getReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - [ QueryArg ("flag", "boolX") Flag ] - , _reqMethod = "GET" - , _reqHeaders = [HeaderArg ("header", "listX of stringX")] - , _reqBody = Nothing - , _reqReturnType = "intX" - , _funcName = ["get", "test"] - } + it "collects all info for get request" $ do + shouldBe getReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + [ QueryArg (Arg "flag" "boolX") Flag ] + , _reqMethod = "GET" + , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"] + , _reqBody = Nothing + , _reqReturnType = Just "intX" + , _reqFuncName = FunctionName ["get", "test"] + } - it "collects all info for post request" $ do - shouldBe postReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - [ QueryArg ("param", "intX") Normal ] - , _reqMethod = "POST" - , _reqHeaders = [] - , _reqBody = Just "listX of stringX" - , _reqReturnType = "voidX" - , _funcName = ["post", "test"] - } + it "collects all info for post request" $ do + shouldBe postReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + [ QueryArg (Arg "param" "intX") Normal ] + , _reqMethod = "POST" + , _reqHeaders = [] + , _reqBody = Just "listX of stringX" + , _reqReturnType = Just "voidX" + , _reqFuncName = FunctionName ["post", "test"] + } - it "collects all info for put request" $ do - shouldBe putReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" ] - -- Shoud this be |intX| or |listX of intX| ? - [ QueryArg ("params", "listX of intX") List ] - , _reqMethod = "PUT" - , _reqHeaders = [] - , _reqBody = Just "stringX" - , _reqReturnType = "voidX" - , _funcName = ["put", "test"] - } - - it "collects all info for delete request" $ do - shouldBe deleteReq $ defReq - { _reqUrl = Url - [ Segment $ Static "test" - , Segment $ Cap ("id", "intX") ] - [] - , _reqMethod = "DELETE" - , _reqHeaders = [] - , _reqBody = Nothing - , _reqReturnType = "voidX" - , _funcName = ["delete", "test", "by", "id"] - } + it "collects all info for put request" $ do + shouldBe putReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" ] + -- Shoud this be |intX| or |listX of intX| ? + [ QueryArg (Arg "params" "listX of intX") List ] + , _reqMethod = "PUT" + , _reqHeaders = [] + , _reqBody = Just "stringX" + , _reqReturnType = Just "voidX" + , _reqFuncName = FunctionName ["put", "test"] + } + it "collects all info for delete request" $ do + shouldBe deleteReq $ defReq + { _reqUrl = Url + [ Segment $ Static "test" + , Segment $ Cap (Arg "id" "intX") ] + [] + , _reqMethod = "DELETE" + , _reqHeaders = [] + , _reqBody = Nothing + , _reqReturnType = Just "voidX" + , _reqFuncName = FunctionName ["delete", "test", "by", "id"] + } diff --git a/servant-js/CHANGELOG.md b/servant-js/CHANGELOG.md index 575391d0..770f2a72 100644 --- a/servant-js/CHANGELOG.md +++ b/servant-js/CHANGELOG.md @@ -1,6 +1,8 @@ -HEAD +0.5 ---- +* Extract javascript-obvlious types and helpers to *servant-foreign* +* Use `text` package instead of `String` * Provide new targets for code generation along with the old jQuery one: vanilla Javascript and Angular.js * Greatly simplify usage of this library by reducing down the API to just 2 functions: `jsForAPI` and `writeJSForAPI` + the choice of a code generator * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators diff --git a/servant-js/LICENSE b/servant-js/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-js/LICENSE +++ b/servant-js/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-js/include/overlapping-compat.h b/servant-js/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-js/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-js/servant-js.cabal b/servant-js/servant-js.cabal index 53a74e9d..660efbec 100644 --- a/servant-js/servant-js.cabal +++ b/servant-js/servant-js.cabal @@ -1,5 +1,5 @@ name: servant-js -version: 0.5 +version: 0.6 synopsis: Automatically derive javascript functions to query servant webservices. description: Automatically derive javascript functions to query servant webservices. @@ -13,15 +13,16 @@ description: license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Maksymilian Owsianny -maintainer: alpmestan@gmail.com -copyright: 2014 Alp Mestanogullari +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: + include/*.h CHANGELOG.md README.md source-repository head @@ -41,14 +42,16 @@ library Servant.JS.JQuery Servant.JS.Vanilla build-depends: base >= 4.5 && <5 + , base-compat >= 0.9 , charset >= 0.3 , lens >= 4 - , servant-foreign == 0.5.* + , servant-foreign == 0.6.* , text >= 1.2 && < 1.3 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable counter main-is: counter.hs @@ -61,11 +64,11 @@ executable counter buildable: False build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + , aeson >= 0.7 && < 0.12 , filepath >= 1 , lens >= 4 - , servant == 0.5.* - , servant-server == 0.5.* + , servant == 0.6.* + , servant-server == 0.6.* , servant-js , stm , transformers @@ -81,6 +84,7 @@ test-suite spec Servant.JSSpec Servant.JSSpec.CustomHeaders build-depends: base + , base-compat , hspec >= 2.1.8 , hspec-expectations , language-ecmascript >= 0.16 diff --git a/servant-js/src/Servant/JS.hs b/servant-js/src/Servant/JS.hs index 443b758b..4afb38db 100644 --- a/servant-js/src/Servant/JS.hs +++ b/servant-js/src/Servant/JS.hs @@ -128,22 +128,22 @@ import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes) -- | Generate the data necessary to generate javascript code -- for all the endpoints of an API, as ':<|>'-separated values -- of type 'AjaxReq'. -javascript :: HasForeign NoTypes layout => Proxy layout -> Foreign layout -javascript p = foreignFor (Proxy :: Proxy NoTypes) p defReq +javascript :: HasForeign NoTypes () layout => Proxy layout -> Foreign () layout +javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p defReq -- | Directly generate all the javascript functions for your API -- from a 'Proxy' for your API type. You can then write it to -- a file or integrate it in a page, for example. -jsForAPI :: (HasForeign NoTypes api, GenerateList (Foreign api)) +jsForAPI :: (HasForeign NoTypes () api, GenerateList () (Foreign () api)) => Proxy api -- ^ proxy for your API type -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> Text -- ^ a text that you can embed in your pages or write to a file -jsForAPI p gen = gen (listFromAPI (Proxy :: Proxy NoTypes) p) +jsForAPI p gen = gen (listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) p) -- | Directly generate all the javascript functions for your API -- from a 'Proxy' for your API type using the given generator -- and write the resulting code to a file at the given path. -writeJSForAPI :: (HasForeign NoTypes api, GenerateList (Foreign api)) +writeJSForAPI :: (HasForeign NoTypes () api, GenerateList () (Foreign () api)) => Proxy api -- ^ proxy for your API type -> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> FilePath -- ^ path to the file you want to write the resulting javascript code into diff --git a/servant-js/src/Servant/JS/Angular.hs b/servant-js/src/Servant/JS/Angular.hs index 2f1b42fb..5c93610d 100644 --- a/servant-js/src/Servant/JS/Angular.hs +++ b/servant-js/src/Servant/JS/Angular.hs @@ -6,6 +6,7 @@ import Data.Maybe (isJust) import Data.Monoid import qualified Data.Text as T import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import Servant.Foreign import Servant.JS.Internal @@ -68,16 +69,19 @@ generateAngularJSWith ngOptions opts req = "\n" <> <> " { url: " <> url <> "\n" <> dataBody <> reqheaders - <> " , method: '" <> method <> "'\n" + <> " , method: '" <> decodeUtf8 method <> "'\n" <> " });\n" <> "}\n" where argsStr = T.intercalate ", " args args = http ++ captures - ++ map (view $ argName._1) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs -- If we want to generate Top Level Function, they must depend on -- the $http service, if we generate a service, the functions will @@ -86,9 +90,9 @@ generateAngularJSWith ngOptions opts req = "\n" <> 0 -> ["$http"] _ -> [] - captures = map (fst . captureArg) + captures = map (view argPath . captureArg) . filter isCapture - $ req ^. reqUrl.path + $ req ^. reqUrl . path hs = req ^. reqHeaders @@ -109,10 +113,11 @@ generateAngularJSWith ngOptions opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . argPath <> + "\": " <> toJSHeader header namespace = if hasService @@ -127,7 +132,7 @@ generateAngularJSWith ngOptions opts req = "\n" <> fsep = if hasService then ":" else " =" - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Axios.hs b/servant-js/src/Servant/JS/Axios.hs index 50bed9eb..3b299cd4 100644 --- a/servant-js/src/Servant/JS/Axios.hs +++ b/servant-js/src/Servant/JS/Axios.hs @@ -5,6 +5,7 @@ import Control.Lens import Data.Maybe (isJust) import Data.Monoid import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import qualified Data.Text as T import Servant.Foreign import Servant.JS.Internal @@ -61,11 +62,14 @@ generateAxiosJSWith aopts opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs - captures = map (fst . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -103,10 +107,11 @@ generateAxiosJSWith aopts opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . argPath <> + "\": " <> toJSHeader header namespace = if hasNoModule @@ -115,9 +120,9 @@ generateAxiosJSWith aopts opts req = "\n" <> where hasNoModule = moduleName opts == "" - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) - method = T.toLower $ req ^. reqMethod + method = T.toLower . decodeUtf8 $ req ^. reqMethod url = if url' == "'" then "'/'" else url' url' = "'" <> urlPrefix opts diff --git a/servant-js/src/Servant/JS/Internal.hs b/servant-js/src/Servant/JS/Internal.hs index 481536ad..3c817e1e 100644 --- a/servant-js/src/Servant/JS/Internal.hs +++ b/servant-js/src/Servant/JS/Internal.hs @@ -1,4 +1,6 @@ -{-#LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + module Servant.JS.Internal ( JavaScriptGenerator , CommonGeneratorOptions(..) @@ -19,7 +21,20 @@ module Servant.JS.Internal , reqHeaders , HasForeign(..) , HasForeignType(..) + , GenerateList(..) + , NoTypes + , HeaderArg + , ArgType(..) , HeaderArg(..) + , QueryArg(..) + , Req(..) + , Segment(..) + , SegmentType(..) + , Url(..) + , Path + , Arg(..) + , FunctionName(..) + , PathSegment(..) , concatCase , snakeCase , camelCase @@ -32,7 +47,7 @@ module Servant.JS.Internal , Header ) where -import Control.Lens ((^.), _1) +import Control.Lens hiding (List) import qualified Data.CharSet as Set import qualified Data.CharSet.Unicode.Category as Set import Data.Monoid @@ -40,23 +55,30 @@ import qualified Data.Text as T import Data.Text (Text) import Servant.Foreign -type AjaxReq = Req +type AjaxReq = Req () -- A 'JavascriptGenerator' just takes the data found in the API type -- for each endpoint and generates Javascript code in a Text. Several -- generators are available in this package. -type JavaScriptGenerator = [Req] -> Text +type JavaScriptGenerator = [Req ()] -> Text -- | This structure is used by specific implementations to let you -- customize the output data CommonGeneratorOptions = CommonGeneratorOptions { - functionNameBuilder :: FunctionName -> Text -- ^ function generating function names - , requestBody :: Text -- ^ name used when a user want to send the request body (to let you redefine it) - , successCallback :: Text -- ^ name of the callback parameter when the request was successful - , errorCallback :: Text -- ^ name of the callback parameter when the request reported an error - , moduleName :: Text -- ^ namespace on which we define the foreign function (empty mean local var) - , urlPrefix :: Text -- ^ a prefix we should add to the Url in the codegen + functionNameBuilder :: FunctionName -> Text + -- ^ function generating function names + , requestBody :: Text + -- ^ name used when a user want to send the request body + -- (to let you redefine it) + , successCallback :: Text + -- ^ name of the callback parameter when the request was successful + , errorCallback :: Text + -- ^ name of the callback parameter when the request reported an error + , moduleName :: Text + -- ^ namespace on which we define the foreign function (empty mean local var) + , urlPrefix :: Text + -- ^ a prefix we should add to the Url in the codegen } -- | Default options. @@ -115,8 +137,9 @@ toValidFunctionName t = , Set.connectorPunctuation ] -toJSHeader :: HeaderArg -> Text -toJSHeader (HeaderArg n) = toValidFunctionName ("header" <> fst n) +toJSHeader :: HeaderArg f -> Text +toJSHeader (HeaderArg n) + = toValidFunctionName ("header" <> n ^. argName . _PathSegment) toJSHeader (ReplaceHeaderArg n p) | pn `T.isPrefixOf` p = pv <> " + \"" <> rp <> "\"" | pn `T.isSuffixOf` p = "\"" <> rp <> "\" + " <> pv @@ -124,34 +147,35 @@ toJSHeader (ReplaceHeaderArg n p) <> "\"" | otherwise = p where - pv = toValidFunctionName ("header" <> fst n) - pn = "{" <> fst n <> "}" + pv = toValidFunctionName ("header" <> n ^. argName . _PathSegment) + pn = "{" <> n ^. argName . _PathSegment <> "}" rp = T.replace pn "" p -jsSegments :: [Segment] -> Text +jsSegments :: [Segment f] -> Text jsSegments [] = "" jsSegments [x] = "/" <> segmentToStr x False jsSegments (x:xs) = "/" <> segmentToStr x True <> jsSegments xs -segmentToStr :: Segment -> Bool -> Text +segmentToStr :: Segment f -> Bool -> Text segmentToStr (Segment st) notTheEnd = segmentTypeToStr st <> if notTheEnd then "" else "'" -segmentTypeToStr :: SegmentType -> Text -segmentTypeToStr (Static s) = s -segmentTypeToStr (Cap s) = "' + encodeURIComponent(" <> fst s <> ") + '" +segmentTypeToStr :: SegmentType f -> Text +segmentTypeToStr (Static s) = s ^. _PathSegment +segmentTypeToStr (Cap s) = + "' + encodeURIComponent(" <> s ^. argName . _PathSegment <> ") + '" -jsGParams :: Text -> [QueryArg] -> Text +jsGParams :: Text -> [QueryArg f] -> Text jsGParams _ [] = "" jsGParams _ [x] = paramToStr x False jsGParams s (x:xs) = paramToStr x True <> s <> jsGParams s xs -jsParams :: [QueryArg] -> Text +jsParams :: [QueryArg f] -> Text jsParams = jsGParams "&" -paramToStr :: QueryArg -> Bool -> Text +paramToStr :: QueryArg f -> Bool -> Text paramToStr qarg notTheEnd = - case qarg ^. argType of + case qarg ^. queryArgType of Normal -> name <> "=' + encodeURIComponent(" <> name @@ -161,4 +185,4 @@ paramToStr qarg notTheEnd = <> "[]=' + encodeURIComponent(" <> name <> if notTheEnd then ") + '" else ")" - where name = qarg ^. argName . _1 + where name = qarg ^. queryArgName . argName . _PathSegment diff --git a/servant-js/src/Servant/JS/JQuery.hs b/servant-js/src/Servant/JS/JQuery.hs index 722d9c07..98038f0c 100644 --- a/servant-js/src/Servant/JS/JQuery.hs +++ b/servant-js/src/Servant/JS/JQuery.hs @@ -6,9 +6,11 @@ import Data.Maybe (isJust) import Data.Monoid import qualified Data.Text as T import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import Servant.Foreign import Servant.JS.Internal + -- | Generate javascript functions that use the /jQuery/ library -- to make the AJAX calls. Uses 'defCommonGeneratorOptions' -- for the generator options. @@ -35,18 +37,21 @@ generateJQueryJSWith opts req = "\n" <> <> dataBody <> reqheaders <> " , error: " <> onError <> "\n" - <> " , type: '" <> method <> "'\n" + <> " , type: '" <> decodeUtf8 method <> "'\n" <> " });\n" <> "}\n" where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map (toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -72,15 +77,16 @@ generateJQueryJSWith opts req = "\n" <> then "" else " , headers: { " <> headersStr <> " }\n" - where headersStr = T.intercalate ", " $ map headerStr hs - headerStr header = "\"" <> - fst (headerArg header) <> - "\": " <> toJSHeader header + where + headersStr = T.intercalate ", " $ map headerStr hs + headerStr header = "\"" <> + header ^. headerArg . argPath <> + "\": " <> toJSHeader header namespace = if (moduleName opts) == "" then "var " else (moduleName opts) <> "." - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/src/Servant/JS/Vanilla.hs b/servant-js/src/Servant/JS/Vanilla.hs index 22b29b4c..216fbc7f 100644 --- a/servant-js/src/Servant/JS/Vanilla.hs +++ b/servant-js/src/Servant/JS/Vanilla.hs @@ -4,6 +4,7 @@ module Servant.JS.Vanilla where import Control.Lens import Data.Maybe (isJust) import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8) import qualified Data.Text as T import Data.Monoid import Servant.Foreign @@ -31,16 +32,19 @@ generateVanillaJSWith opts req = "\n" <> fname <> " = function(" <> argsStr <> ")\n" <> "{\n" <> " var xhr = new XMLHttpRequest();\n" - <> " xhr.open('" <> method <> "', " <> url <> ", true);\n" + <> " xhr.open('" <> decodeUtf8 method <> "', " <> url <> ", true);\n" <> reqheaders <> " xhr.setRequestHeader(\"Accept\",\"application/json\");\n" <> (if isJust (req ^. reqBody) then " xhr.setRequestHeader(\"Content-Type\",\"application/json\");\n" else "") <> " xhr.onreadystatechange = function (e) {\n" <> " if (xhr.readyState == 4) {\n" + <> " if (xhr.status == 204 || xhr.status == 205) {\n" + <> " onSuccess();\n" + <> " } else if (xhr.status >= 200 && xhr.status < 300) {\n" <> " var value = JSON.parse(xhr.responseText);\n" - <> " if (xhr.status == 200 || xhr.status == 201) {\n" <> " onSuccess(value);\n" <> " } else {\n" + <> " var value = JSON.parse(xhr.responseText);\n" <> " onError(value);\n" <> " }\n" <> " }\n" @@ -50,12 +54,15 @@ generateVanillaJSWith opts req = "\n" <> where argsStr = T.intercalate ", " args args = captures - ++ map (view $ argName._1) queryparams + ++ map (view $ queryArgName . argPath) queryparams ++ body - ++ map (toValidFunctionName . (<>) "header" . fst . headerArg) hs + ++ map ( toValidFunctionName + . (<>) "header" + . view (headerArg . argPath) + ) hs ++ [onSuccess, onError] - captures = map (fst . captureArg) + captures = map (view argPath . captureArg) . filter isCapture $ req ^. reqUrl.path @@ -81,15 +88,16 @@ generateVanillaJSWith opts req = "\n" <> then "" else headersStr <> "\n" - where headersStr = T.intercalate "\n" $ map headerStr hs - headerStr header = " xhr.setRequestHeader(\"" <> - fst (headerArg header) <> - "\", " <> toJSHeader header <> ");" + where + headersStr = T.intercalate "\n" $ map headerStr hs + headerStr header = " xhr.setRequestHeader(\"" <> + header ^. headerArg . argPath <> + "\", " <> toJSHeader header <> ");" namespace = if moduleName opts == "" then "var " else (moduleName opts) <> "." - fname = namespace <> (functionNameBuilder opts $ req ^. funcName) + fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName) method = req ^. reqMethod url = if url' == "'" then "'/'" else url' diff --git a/servant-js/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index 23fe4326..8d23a8ab 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} @@ -7,20 +6,21 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Servant.JSSpec where import Data.Either (isRight) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ((<>),mconcat) -#else -import Data.Monoid ((<>)) -#endif +import Data.Monoid () +import Data.Monoid.Compat ((<>)) import Data.Proxy import Data.Text (Text) import qualified Data.Text as T import Language.ECMAScript3.Parser (program, parse) +import Prelude () +import Prelude.Compat import Test.Hspec hiding (shouldContain, shouldNotContain) +import Servant.API.Internal.Test.ComprehensiveAPI import Servant.JS import Servant.JS.Internal import qualified Servant.JS.Angular as NG @@ -29,6 +29,13 @@ import qualified Servant.JS.JQuery as JQ import qualified Servant.JS.Vanilla as JS import Servant.JSSpec.CustomHeaders +-- * comprehensive api + +-- This declaration simply checks that all instances are in place. +_ = jsForAPI comprehensiveAPI vanillaJS :: Text + +-- * specs + type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] Text :> Post '[JSON] Bool :<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool @@ -98,7 +105,7 @@ a `shouldNotContain` b = shouldNotSatisfy a (T.isInfixOf b) axiosSpec :: Spec axiosSpec = describe specLabel $ do - let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy TestAPI) + let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI) it "should add withCredentials when needed" $ do let jsText = genJS withCredOpts $ reqList output jsText @@ -122,7 +129,7 @@ axiosSpec = describe specLabel $ do angularSpec :: TestNames -> Spec angularSpec test = describe specLabel $ do - let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy TestAPI) + let reqList = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy ()) (Proxy :: Proxy TestAPI) it "should implement a service globally" $ do let jsText = genJS reqList output jsText diff --git a/servant-js/test/Servant/JSSpec/CustomHeaders.hs b/servant-js/test/Servant/JSSpec/CustomHeaders.hs index 150436e3..6d881aa4 100644 --- a/servant-js/test/Servant/JSSpec/CustomHeaders.hs +++ b/servant-js/test/Servant/JSSpec/CustomHeaders.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PolyKinds #-} @@ -22,36 +23,37 @@ import Servant.JS.Internal -- using -- Basic, Digest, whatever. data Authorization (sym :: Symbol) a -instance (KnownSymbol sym, HasForeign lang sublayout) - => HasForeign lang (Authorization sym a :> sublayout) where - type Foreign (Authorization sym a :> sublayout) = Foreign sublayout +instance (KnownSymbol sym, HasForeign lang () sublayout) + => HasForeign lang () (Authorization sym a :> sublayout) where + type Foreign () (Authorization sym a :> sublayout) = Foreign () sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("Authorization", "") $ - tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ + [ ReplaceHeaderArg (Arg "Authorization" ()) + $ tokenType (pack . symbolVal $ (Proxy :: Proxy sym)) ] where tokenType t = t <> " {Authorization}" -- | This is a combinator that fetches an X-MyLovelyHorse header. data MyLovelyHorse a -instance (HasForeign lang sublayout) - => HasForeign lang (MyLovelyHorse a :> sublayout) where - type Foreign (MyLovelyHorse a :> sublayout) = Foreign sublayout +instance (HasForeign lang () sublayout) + => HasForeign lang () (MyLovelyHorse a :> sublayout) where + type Foreign () (MyLovelyHorse a :> sublayout) = Foreign () sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-MyLovelyHorse", "") tpl ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-MyLovelyHorse" ()) tpl ] where tpl = "I am good friends with {X-MyLovelyHorse}" -- | This is a combinator that fetches an X-WhatsForDinner header. data WhatsForDinner a -instance (HasForeign lang sublayout) - => HasForeign lang (WhatsForDinner a :> sublayout) where - type Foreign (WhatsForDinner a :> sublayout) = Foreign sublayout +instance (HasForeign lang () sublayout) + => HasForeign lang () (WhatsForDinner a :> sublayout) where + type Foreign () (WhatsForDinner a :> sublayout) = Foreign () sublayout - foreignFor lang Proxy req = foreignFor lang (Proxy :: Proxy sublayout) $ - req & reqHeaders <>~ [ ReplaceHeaderArg ("X-WhatsForDinner", "") tpl ] + foreignFor lang ftype Proxy req = foreignFor lang ftype (Proxy :: Proxy sublayout) $ + req & reqHeaders <>~ [ ReplaceHeaderArg (Arg "X-WhatsForDinner" ()) tpl ] where tpl = "I would like {X-WhatsForDinner} with a cherry on top." diff --git a/servant-lucid/LICENSE b/servant-lucid/LICENSE index 0b0a2174..1d0ce8da 100644 --- a/servant-lucid/LICENSE +++ b/servant-lucid/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Julian K. Arni +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-lucid/include/overlapping-compat.h b/servant-lucid/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-lucid/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-lucid/servant-lucid.cabal b/servant-lucid/servant-lucid.cabal index 77cf3ee1..325cbb73 100644 --- a/servant-lucid/servant-lucid.cabal +++ b/servant-lucid/servant-lucid.cabal @@ -2,18 +2,18 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: servant-lucid -version: 0.5 +version: 0.6 synopsis: Servant support for lucid -- description: homepage: http://haskell-servant.github.io/ license: BSD3 license-file: LICENSE -author: Julian K. Arni -maintainer: jkarni@gmail.com --- copyright: +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple --- extra-source-files: +extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant/issues source-repository head @@ -27,6 +27,7 @@ library build-depends: base >=4.7 && <5 , http-media , lucid - , servant == 0.5.* + , servant == 0.6.* hs-source-dirs: src default-language: Haskell2010 + include-dirs: include diff --git a/servant-lucid/src/Servant/HTML/Lucid.hs b/servant-lucid/src/Servant/HTML/Lucid.hs index f222c6ac..ec62a21c 100644 --- a/servant-lucid/src/Servant/HTML/Lucid.hs +++ b/servant-lucid/src/Servant/HTML/Lucid.hs @@ -3,9 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" -- | An @HTML@ empty data type with `MimeRender` instances for @lucid@'s -- `ToHtml` class and `Html` datatype. @@ -28,16 +27,10 @@ data HTML deriving Typeable instance Accept HTML where contentType _ = "text" M.// "html" M./: ("charset", "utf-8") -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif +instance OVERLAPPABLE_ ToHtml a => MimeRender HTML a where mimeRender _ = renderBS . toHtml -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif +instance OVERLAPPING_ MimeRender HTML (Html a) where mimeRender _ = renderBS diff --git a/servant-mock/.ghci b/servant-mock/.ghci new file mode 100644 index 00000000..0215492d --- /dev/null +++ b/servant-mock/.ghci @@ -0,0 +1 @@ +:set -Wall -itest -isrc -optP-include -optPdist/build/autogen/cabal_macros.h -Iinclude diff --git a/servant-mock/LICENSE b/servant-mock/LICENSE index f2e47b91..68d30586 100644 --- a/servant-mock/LICENSE +++ b/servant-mock/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Alp Mestanogullari +Copyright (c) 2015-2016, Servant Contributors All rights reserved. diff --git a/servant-mock/example/main.hs b/servant-mock/example/main.hs index 51ba7329..4a457467 100644 --- a/servant-mock/example/main.hs +++ b/servant-mock/example/main.hs @@ -20,4 +20,4 @@ api :: Proxy API api = Proxy main :: IO () -main = run 8080 (serve api $ mock api) +main = run 8080 (serve api $ mock api Proxy) diff --git a/servant-mock/include/overlapping-compat.h b/servant-mock/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-mock/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-mock/servant-mock.cabal b/servant-mock/servant-mock.cabal index 14455c99..3806b79d 100644 --- a/servant-mock/servant-mock.cabal +++ b/servant-mock/servant-mock.cabal @@ -1,5 +1,5 @@ name: servant-mock -version: 0.5 +version: 0.6 synopsis: Derive a mock server for free from your servant API types description: Derive a mock server for free from your servant API types @@ -8,17 +8,17 @@ description: homepage: http://github.com/haskell-servant/servant license: BSD3 license-file: LICENSE -author: Alp Mestanogullari -maintainer: alpmestan@gmail.com -copyright: 2015 Alp Mestanogullari +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2015-2016 Servant Contributors category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 flag example description: Build the example too - manual: True - default: False + default: True library exposed-modules: @@ -34,6 +34,7 @@ library wai >= 3.0 && <3.3 hs-source-dirs: src default-language: Haskell2010 + include-dirs: include executable mock-app main-is: main.hs @@ -44,3 +45,24 @@ executable mock-app buildable: True else buildable: False + +test-suite spec + type: exitcode-stdio-1.0 + ghc-options: + -Wall -fno-warn-name-shadowing + default-language: Haskell2010 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Servant.MockSpec + build-depends: + base, + hspec, + hspec-wai, + QuickCheck, + servant, + servant-server, + servant-mock, + aeson, + bytestring-conversion, + wai diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 3fa5d077..9e9fed8a 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -1,11 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + +#include "overlapping-compat.h" + -- | -- Module : Servant.Mock -- Copyright : 2015 Alp Mestanogullari @@ -69,7 +74,7 @@ import Test.QuickCheck.Gen (Gen, generate) -- than turns them into random-response-generating -- request handlers, hence providing an instance for -- all the combinators of the core /servant/ library. -class HasServer api => HasMock api where +class HasServer api context => HasMock api context where -- | Calling this method creates request handlers of -- the right type to implement the API described by -- @api@ that just generate random response values of @@ -99,68 +104,68 @@ class HasServer api => HasMock api where -- So under the hood, 'mock' uses the 'IO' bit to generate -- random values of type 'User' and 'Book' every time these -- endpoints are requested. - mock :: Proxy api -> Server api + mock :: Proxy api -> Proxy context -> Server api -instance (HasMock a, HasMock b) => HasMock (a :<|> b) where - mock _ = mock (Proxy :: Proxy a) :<|> mock (Proxy :: Proxy b) +instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where + mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context -instance (KnownSymbol path, HasMock rest) => HasMock (path :> rest) where +instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where mock _ = mock (Proxy :: Proxy rest) -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) => HasMock (Capture s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (Capture s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (AllCTUnrender ctypes a, HasMock rest) => HasMock (ReqBody ctypes a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (AllCTUnrender ctypes a, HasMock rest context) => HasMock (ReqBody ctypes a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (RemoteHost :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (RemoteHost :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (IsSecure :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (IsSecure :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (Vault :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (Vault :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance HasMock rest => HasMock (HttpVersion :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance HasMock rest context => HasMock (HttpVersion :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) - => HasMock (QueryParam s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) + => HasMock (QueryParam s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, FromHttpApiData a, HasMock rest) - => HasMock (QueryParams s a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) + => HasMock (QueryParams s a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol s, HasMock rest) => HasMock (QueryFlag s :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (KnownSymbol h, FromHttpApiData a, HasMock rest) => HasMock (Header h a :> rest) where - mock _ = \_ -> mock (Proxy :: Proxy rest) +instance (KnownSymbol h, FromHttpApiData a, HasMock rest context) => HasMock (Header h a :> rest) context where + mock _ context = \_ -> mock (Proxy :: Proxy rest) context -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Delete ctypes a) where - mock _ = mockArbitrary +instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) + => HasMock (Verb method status ctypes a) context where + mock _ _ = mockArbitrary -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Get ctypes a) where - mock _ = mockArbitrary +instance OVERLAPPING_ + (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), + Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a) + => HasMock (Verb method status ctypes (Headers headerTypes a)) context where + mock _ _ = mockArbitrary -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Patch ctypes a) where - mock _ = mockArbitrary - -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Post ctypes a) where - mock _ = mockArbitrary - -instance (Arbitrary a, AllCTRender ctypes a) => HasMock (Put ctypes a) where - mock _ = mockArbitrary - -instance HasMock Raw where - mock _ = \_req respond -> do +instance HasMock Raw context where + mock _ _ = \_req respond -> do bdy <- genBody respond $ responseLBS status200 [] bdy where genBody = pack <$> generate (vector 100 :: Gen [Char]) +instance (HasContextEntry context (NamedContext name subContext), HasMock rest subContext) => + HasMock (WithNamedContext name subContext rest) context where + + mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext) + mockArbitrary :: (MonadIO m, Arbitrary a) => m a mockArbitrary = liftIO (generate arbitrary) @@ -175,5 +180,3 @@ instance Arbitrary (HList '[]) where instance (Arbitrary a, Arbitrary (HList hs)) => Arbitrary (HList (Header h a ': hs)) where arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary - - diff --git a/servant-mock/test/Servant/MockSpec.hs b/servant-mock/test/Servant/MockSpec.hs new file mode 100644 index 00000000..7d7b32ac --- /dev/null +++ b/servant-mock/test/Servant/MockSpec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.MockSpec where + +import Data.Aeson as Aeson +import Data.ByteString.Conversion.To +import Data.Proxy +import Data.String +import GHC.Generics +import Network.Wai +import Servant.API +import Test.Hspec hiding (pending) +import Test.Hspec.Wai +import Test.QuickCheck + +import Servant +import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.Mock + +-- This declaration simply checks that all instances are in place. +_ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]]) + +data Body + = Body + | ArbitraryBody + deriving (Generic) + +instance ToJSON Body + +instance Arbitrary Body where + arbitrary = return ArbitraryBody + +data TestHeader + = TestHeader + | ArbitraryHeader + deriving (Show) + +instance ToByteString TestHeader where + builder = fromString . show + +instance Arbitrary TestHeader where + arbitrary = return ArbitraryHeader + +spec :: Spec +spec = do + describe "mock" $ do + context "Get" $ do + let api :: Proxy (Get '[JSON] Body) + api = Proxy + app = serve api (mock api Proxy) + with (return app) $ do + it "serves arbitrary response bodies" $ do + get "/" `shouldRespondWith` 200{ + matchBody = Just $ Aeson.encode ArbitraryBody + } + + context "response headers" $ do + let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body)) + withHeader = Proxy + withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) + withoutHeader = Proxy + toApp :: (HasMock api '[]) => Proxy api -> IO Application + toApp api = return $ serve api (mock api (Proxy :: Proxy '[])) + with (toApp withHeader) $ do + it "serves arbitrary response bodies" $ do + get "/" `shouldRespondWith` 200{ + matchHeaders = return $ MatchHeader $ \ h -> + if h == [("Content-Type", "application/json"), ("foo", "ArbitraryHeader")] + then Nothing + else Just ("headers not correct\n") + } + + with (toApp withoutHeader) $ do + it "works for no additional headers" $ do + get "/" `shouldRespondWith` 200{ + matchHeaders = return $ MatchHeader $ \ h -> + if h == [("Content-Type", "application/json")] + then Nothing + else Just ("headers not correct\n") + } diff --git a/servant-mock/test/Spec.hs b/servant-mock/test/Spec.hs new file mode 100644 index 00000000..a824f8c3 --- /dev/null +++ b/servant-mock/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index 5ba871ee..8b1c25e2 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,6 +1,14 @@ -HEAD ----- +0.6 +--- +* Query parameters that can't be parsed result in a `400` (was `404`). + +0.5 +--- + +* Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327). + This is a breaking change, as the signatures of both `route`, `serve` and the + typeclass `HasServer` now take an additional parameter. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Drop `EitherT` in favor of `ExceptT` * Use `http-api-data` instead of `Servant.Common.Text` @@ -8,6 +16,8 @@ HEAD * Remove `RouteMismatch`. * Redefined constructors of `RouteResult`. * Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`) +* Added support for Basic Authentication +* Add generalized authentication support via the `AuthServerData` type family and `AuthHandler` handler 0.4.1 ----- diff --git a/servant-server/LICENSE b/servant-server/LICENSE index bfee8018..9717a9ce 100644 --- a/servant-server/LICENSE +++ b/servant-server/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant-server/include/overlapping-compat.h b/servant-server/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant-server/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index ff2fb200..5ba00c65 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -1,5 +1,5 @@ name: servant-server -version: 0.5 +version: 0.6 synopsis: A family of combinators for defining webservices APIs and serving them description: A family of combinators for defining webservices APIs and serving them @@ -15,14 +15,15 @@ homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple cabal-version: >=1.10 tested-with: GHC >= 7.8 extra-source-files: + include/*.h CHANGELOG.md README.md bug-reports: http://github.com/haskell-servant/servant/issues @@ -35,7 +36,10 @@ library exposed-modules: Servant Servant.Server + Servant.Server.Experimental.Auth Servant.Server.Internal + Servant.Server.Internal.BasicAuth + Servant.Server.Internal.Context Servant.Server.Internal.Enter Servant.Server.Internal.Router Servant.Server.Internal.RoutingApplication @@ -43,8 +47,10 @@ library Servant.Utils.StaticFiles build-depends: base >= 4.7 && < 5 - , aeson >= 0.7 && < 0.11 + , base-compat >= 0.9 + , aeson >= 0.7 && < 0.12 , attoparsec >= 0.12 && < 0.14 + , base64-bytestring == 1.0.* , bytestring >= 0.10 && < 0.11 , containers >= 0.5 && < 0.6 , http-api-data >= 0.1 && < 0.3 @@ -54,7 +60,7 @@ library , mmorph >= 1 , network >= 2.6 && < 2.7 , safe >= 0.3 && < 0.4 - , servant == 0.5.* + , servant == 0.6.* , split >= 0.2 && < 0.3 , string-conversions >= 0.3 && < 0.5 , system-filepath >= 0.4 && < 0.5 @@ -65,10 +71,12 @@ library , wai >= 3.0 && < 3.3 , wai-app-static >= 3.0 && < 3.2 , warp >= 3.0 && < 3.3 + , word8 == 0.1.* hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + include-dirs: include executable greet main-is: greet.hs @@ -92,12 +100,16 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: + Servant.Server.ErrorSpec + Servant.Server.Internal.ContextSpec Servant.Server.Internal.EnterSpec Servant.ServerSpec + Servant.Server.UsingContextSpec + Servant.Server.UsingContextSpec.TestCombinators Servant.Utils.StaticFilesSpec - Servant.Server.ErrorSpec build-depends: base == 4.* + , base-compat , aeson , bytestring , bytestring-conversion @@ -113,6 +125,7 @@ test-suite spec , servant , servant-server , string-conversions + , should-not-typecheck == 2.* , temporary , text , transformers @@ -134,3 +147,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index a26941ea..8eff9c66 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} @@ -7,6 +9,7 @@ module Servant.Server ( -- * Run a wai application from an API serve + , serveWithContext , -- * Construct a wai Application from an API toApplication @@ -35,6 +38,22 @@ module Servant.Server , generalizeNat , tweakResponse + -- * Context + , Context(..) + , HasContextEntry(getContextEntry) + -- ** NamedContext + , NamedContext(..) + , descendIntoNamedContext + + -- * Basic Authentication + , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck) + , BasicAuthResult(..) + + -- * General Authentication + -- , AuthHandler(unAuthHandler) + -- , AuthServerData + -- , mkAuthHandler + -- * Default error type , ServantErr(..) -- ** 3XX @@ -63,7 +82,7 @@ module Servant.Server , err415 , err416 , err417 - -- * 5XX + -- ** 5XX , err500 , err501 , err502 @@ -102,10 +121,14 @@ import Servant.Server.Internal.Enter -- > main :: IO () -- > main = Network.Wai.Handler.Warp.run 8080 app -- -serve :: HasServer layout => Proxy layout -> Server layout -> Application -serve p server = toApplication (runRouter (route p d)) +serve :: (HasServer layout '[]) => Proxy layout -> Server layout -> Application +serve p = serveWithContext p EmptyContext + +serveWithContext :: (HasServer layout context) + => Proxy layout -> Context context -> Server layout -> Application +serveWithContext p context server = toApplication (runRouter (route p context d)) where - d = Delayed r r r (\ _ _ -> Route server) + d = Delayed r r r r (\ _ _ _ -> Route server) r = return (Route ()) diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs new file mode 100644 index 00000000..1cc698fc --- /dev/null +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -0,0 +1,66 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Servant.Server.Experimental.Auth where + +import Control.Monad.Trans.Except (ExceptT, + runExceptT) +import Data.Proxy (Proxy (Proxy)) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Network.Wai (Request) + +import Servant ((:>)) +import Servant.API.Experimental.Auth +import Servant.Server.Internal (HasContextEntry, + HasServer, ServerT, + getContextEntry, + route) +import Servant.Server.Internal.Router (Router' (WithRequest)) +import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route), + addAuthCheck) +import Servant.Server.Internal.ServantErr (ServantErr) + +-- * General Auth + +-- | Specify the type of data returned after we've authenticated a request. +-- quite often this is some `User` datatype. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +type family AuthServerData a :: * + +-- | Handlers for AuthProtected resources +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +newtype AuthHandler r usr = AuthHandler + { unAuthHandler :: r -> ExceptT ServantErr IO usr } + deriving (Generic, Typeable) + +-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE +mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr +mkAuthHandler = AuthHandler + +-- | Known orphan instance. +instance ( HasServer api context + , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag))) + ) + => HasServer (AuthProtect tag :> api) context where + + type ServerT (AuthProtect tag :> api) m = + AuthServerData (AuthProtect tag) -> ServerT api m + + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + where + authHandler = unAuthHandler (getContextEntry context) + authCheck = fmap (either FailFatal Route) . runExceptT . authHandler + diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 4200d052..1733f246 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -1,49 +1,60 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif + +#include "overlapping-compat.h" module Servant.Server.Internal ( module Servant.Server.Internal + , module Servant.Server.Internal.Context + , module Servant.Server.Internal.BasicAuth , module Servant.Server.Internal.Router , module Servant.Server.Internal.RoutingApplication , module Servant.Server.Internal.ServantErr ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif -import Control.Monad.Trans.Except (ExceptT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.String (fromString) -import Data.String.Conversions (ConvertibleStrings, cs, (<>)) -import Data.Text (Text) +import Control.Monad.Trans.Except (ExceptT) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.String (fromString) +import Data.String.Conversions (cs, (<>)) +import Data.Text (Text) import Data.Typeable -import GHC.TypeLits (KnownSymbol, symbolVal) -import Network.HTTP.Types hiding (Header, ResponseHeaders) -import Network.Socket (SockAddr) -import Network.Wai (Application, lazyRequestBody, - rawQueryString, requestHeaders, - requestMethod, responseLBS, remoteHost, - isSecure, vault, httpVersion, Response, - Request, pathInfo) -import Servant.API ((:<|>) (..), (:>), Capture, - Delete, Get, Header, - IsSecure(..), Patch, Post, Put, +import GHC.TypeLits (KnownNat, KnownSymbol, natVal, + symbolVal) +import Network.HTTP.Types hiding (Header, ResponseHeaders) +import Network.Socket (SockAddr) +import Network.Wai (Application, Request, Response, + httpVersion, isSecure, + lazyRequestBody, pathInfo, + rawQueryString, remoteHost, + requestHeaders, requestMethod, + responseLBS, vault) +import Prelude () +import Prelude.Compat +import Web.HttpApiData (FromHttpApiData) +import Web.HttpApiData.Internal (parseHeaderMaybe, + parseQueryParamMaybe, + parseUrlPieceMaybe) + +import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture, + Verb, ReflectMethod(reflectMethod), + IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault) + Raw, RemoteHost, ReqBody, Vault, + WithNamedContext) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), @@ -52,17 +63,17 @@ import Servant.API.ContentTypes (AcceptHeader (..), import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders, getResponse) +import Servant.Server.Internal.Context +import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Router import Servant.Server.Internal.RoutingApplication import Servant.Server.Internal.ServantErr -import Web.HttpApiData (FromHttpApiData) -import Web.HttpApiData.Internal (parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe) -class HasServer layout where +class HasServer layout context where type ServerT layout (m :: * -> *) :: * - route :: Proxy layout -> Delayed (Server layout) -> Router + route :: Proxy layout -> Context context -> Delayed (Server layout) -> Router type Server layout = ServerT layout (ExceptT ServantErr IO) @@ -79,18 +90,15 @@ type Server layout = ServerT layout (ExceptT ServantErr IO) -- > server = listAllBooks :<|> postBook -- > where listAllBooks = ... -- > postBook book = ... -instance (HasServer a, HasServer b) => HasServer (a :<|> b) where +instance (HasServer a context, HasServer b context) => HasServer (a :<|> b) context where type ServerT (a :<|> b) m = ServerT a m :<|> ServerT b m - route Proxy server = choice (route pa ((\ (a :<|> _) -> a) <$> server)) - (route pb ((\ (_ :<|> b) -> b) <$> server)) + route Proxy context server = choice (route pa context ((\ (a :<|> _) -> a) <$> server)) + (route pb context ((\ (_ :<|> b) -> b) <$> server)) where pa = Proxy :: Proxy a pb = Proxy :: Proxy b -captured :: FromHttpApiData a => proxy (Capture sym a) -> Text -> Maybe a -captured _ = parseUrlPieceMaybe - -- | If you use 'Capture' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of the type specified by the 'Capture'. @@ -108,21 +116,20 @@ captured _ = parseUrlPieceMaybe -- > server = getBook -- > where getBook :: Text -> ExceptT ServantErr IO Book -- > getBook isbn = ... -instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout) - => HasServer (Capture capture a :> sublayout) where +instance (KnownSymbol capture, FromHttpApiData a, HasServer sublayout context) + => HasServer (Capture capture a :> sublayout) context where type ServerT (Capture capture a :> sublayout) m = a -> ServerT sublayout m - route Proxy d = + route Proxy context d = DynamicRouter $ \ first -> route (Proxy :: Proxy sublayout) - (addCapture d $ case captured captureProxy first of - Nothing -> return $ Fail err404 + context + (addCapture d $ case parseUrlPieceMaybe first :: Maybe a of + Nothing -> return $ Fail err400 Just v -> return $ Route v ) - where - captureProxy = Proxy :: Proxy (Capture capture a) allowedMethodHead :: Method -> Request -> Bool allowedMethodHead method request = method == methodGet && requestMethod request == methodHead @@ -130,8 +137,7 @@ allowedMethodHead method request = method == methodGet && requestMethod request allowedMethod :: Method -> Request -> Bool allowedMethod method request = allowedMethodHead method request || requestMethod request == method -processMethodRouter :: forall a. ConvertibleStrings a B.ByteString - => Maybe (a, BL.ByteString) -> Status -> Method +processMethodRouter :: Maybe (BL.ByteString, BL.ByteString) -> Status -> Method -> Maybe [(HeaderName, B.ByteString)] -> Request -> RouteResult Response processMethodRouter handleA status method headers request = case handleA of @@ -149,7 +155,7 @@ methodCheck method request acceptCheck :: (AllMime list) => Proxy list -> B.ByteString -> IO (RouteResult ()) acceptCheck proxy accH | canHandleAcceptH proxy (AcceptHeader accH) = return $ Route () - | otherwise = return $ Fail err406 + | otherwise = return $ FailFatal err406 methodRouter :: (AllCTRender ctypes a) => Method -> Proxy ctypes -> Status @@ -161,7 +167,7 @@ methodRouter method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let handleA = handleAcceptH proxy (AcceptHeader accH) output processMethodRouter handleA status method Nothing request @@ -177,113 +183,33 @@ methodRouterHeaders method proxy status action = LeafRouter route' | pathIsEmpty request = let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request in runAction (action `addMethodCheck` methodCheck method request - `addAcceptCheck` acceptCheck proxy accH + `addAcceptCheck` acceptCheck proxy accH ) respond $ \ output -> do let headers = getHeaders output handleA = handleAcceptH proxy (AcceptHeader accH) (getResponse output) processMethodRouter handleA status method (Just headers) request | otherwise = respond $ Fail err404 -methodRouterEmpty :: Method - -> Delayed (ExceptT ServantErr IO ()) - -> Router -methodRouterEmpty method action = LeafRouter route' - where - route' request respond - | pathIsEmpty request = do - runAction (addMethodCheck action (methodCheck method request)) respond $ \ () -> - Route $! responseLBS noContent204 [] "" - | otherwise = respond $ Fail err404 +instance OVERLAPPABLE_ + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + ) => HasServer (Verb method status ctypes a) context where --- | If you have a 'Delete' endpoint in your API, --- the handler for this endpoint is meant to delete --- a resource. --- --- The code of the handler will, just like --- for 'Servant.API.Get.Get', 'Servant.API.Post.Post' and --- 'Servant.API.Put.Put', run in @ExceptT ServantErr IO ()@. --- The 'Int' represents the status code and the 'String' a message --- to be returned. You can use 'Control.Monad.Trans.Except.throwE' to --- painlessly error out if the conditions for a successful deletion --- are not met. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a - ) => HasServer (Delete ctypes a) where + type ServerT (Verb method status ctypes a) m = m a - type ServerT (Delete ctypes a) m = m a + route Proxy _ = methodRouter method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) - route Proxy = methodRouter methodDelete (Proxy :: Proxy ctypes) ok200 +instance OVERLAPPING_ + ( AllCTRender ctypes a, ReflectMethod method, KnownNat status + , GetHeaders (Headers h a) + ) => HasServer (Verb method status ctypes (Headers h a)) context where -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Delete ctypes ()) where + type ServerT (Verb method status ctypes (Headers h a)) m = m (Headers h a) - type ServerT (Delete ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodDelete - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Delete ctypes (Headers h v)) where - - type ServerT (Delete ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodDelete (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Get' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Post.Post' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a ) => HasServer (Get ctypes a) where - - type ServerT (Get ctypes a) m = m a - - route Proxy = methodRouter methodGet (Proxy :: Proxy ctypes) ok200 - --- '()' ==> 204 No Content -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Get ctypes ()) where - - type ServerT (Get ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodGet - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Get ctypes (Headers h v)) where - - type ServerT (Get ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodGet (Proxy :: Proxy ctypes) ok200 + route Proxy _ = methodRouterHeaders method (Proxy :: Proxy ctypes) status + where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -- | If you use 'Header' in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function @@ -296,7 +222,7 @@ instance -- Example: -- -- > newtype Referer = Referer Text --- > deriving (Eq, Show, FromHttpApiData, ToText) +-- > deriving (Eq, Show, FromHttpApiData) -- > -- > -- GET /view-my-referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer @@ -305,151 +231,17 @@ instance -- > server = viewReferer -- > where viewReferer :: Referer -> ExceptT ServantErr IO referer -- > viewReferer referer = return referer -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (Header sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (Header sym a :> sublayout) context where type ServerT (Header sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let mheader = parseHeaderMaybe =<< lookup str (requestHeaders request) - in route (Proxy :: Proxy sublayout) (passToServer subserver mheader) + in route (Proxy :: Proxy sublayout) context (passToServer subserver mheader) where str = fromString $ symbolVal (Proxy :: Proxy sym) --- | When implementing the handler for a 'Post' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 201). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a - ) => HasServer (Post ctypes a) where - - type ServerT (Post ctypes a) m = m a - - route Proxy = methodRouter methodPost (Proxy :: Proxy ctypes) created201 - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Post ctypes ()) where - - type ServerT (Post ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPost - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Post ctypes (Headers h v)) where - - type ServerT (Post ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPost (Proxy :: Proxy ctypes) created201 - --- | When implementing the handler for a 'Put' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Post.Post', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we use the type-level list, combined --- with the request's @Accept@ header, to encode the value for you --- (returning a status code of 200). If there was no @Accept@ header or it --- was @*\/\*@, we return encode using the first @Content-Type@ type on the --- list. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a) => HasServer (Put ctypes a) where - - type ServerT (Put ctypes a) m = m a - - route Proxy = methodRouter methodPut (Proxy :: Proxy ctypes) ok200 - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Put ctypes ()) where - - type ServerT (Put ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPut - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Put ctypes (Headers h v)) where - - type ServerT (Put ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPut (Proxy :: Proxy ctypes) ok200 - --- | When implementing the handler for a 'Patch' endpoint, --- just like for 'Servant.API.Delete.Delete', 'Servant.API.Get.Get' --- and 'Servant.API.Put.Put', the handler code runs in the --- @ExceptT ServantErr IO@ monad, where the 'Int' represents --- the status code and the 'String' a message, returned in case of --- failure. You can quite handily use 'Control.Monad.Trans.Except.throwE' --- to quickly fail if some conditions are not met. --- --- If successfully returning a value, we just require that its type has --- a 'ToJSON' instance and servant takes care of encoding it for you, --- yielding status code 200 along the way. -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( AllCTRender ctypes a) => HasServer (Patch ctypes a) where - - type ServerT (Patch ctypes a) m = m a - - route Proxy = methodRouter methodPatch (Proxy :: Proxy ctypes) ok200 - -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - HasServer (Patch ctypes ()) where - - type ServerT (Patch ctypes ()) m = m () - - route Proxy = methodRouterEmpty methodPatch - --- Add response headers -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( GetHeaders (Headers h v), AllCTRender ctypes v - ) => HasServer (Patch ctypes (Headers h v)) where - - type ServerT (Patch ctypes (Headers h v)) m = m (Headers h v) - - route Proxy = methodRouterHeaders methodPatch (Proxy :: Proxy ctypes) ok200 - -- | If you use @'QueryParam' "author" Text@ in one of the endpoints for your API, -- this automatically requires your server-side handler to be a function -- that takes an argument of type @'Maybe' 'Text'@. @@ -471,13 +263,13 @@ instance -- > where getBooksBy :: Maybe Text -> ExceptT ServantErr IO [Book] -- > getBooksBy Nothing = ...return all books... -- > getBooksBy (Just author) = ...return books by the given author... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (QueryParam sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (QueryParam sym a :> sublayout) context where type ServerT (QueryParam sym a :> sublayout) m = Maybe a -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of @@ -485,7 +277,7 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) Just Nothing -> Nothing -- param present with no value -> Nothing Just (Just v) -> parseQueryParamMaybe v -- if present, we try to convert to -- the right type - in route (Proxy :: Proxy sublayout) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) -- | If you use @'QueryParams' "authors" Text@ in one of the endpoints for your API, @@ -507,20 +299,20 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > server = getBooksBy -- > where getBooksBy :: [Text] -> ExceptT ServantErr IO [Book] -- > getBooksBy authors = ...return all books by these authors... -instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) - => HasServer (QueryParams sym a :> sublayout) where +instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout context) + => HasServer (QueryParams sym a :> sublayout) context where type ServerT (QueryParams sym a :> sublayout) m = [a] -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request -- if sym is "foo", we look for query string parameters -- named "foo" or "foo[]" and call parseQueryParam on the -- corresponding values parameters = filter looksLikeParam querytext values = mapMaybe (convert . snd) parameters - in route (Proxy :: Proxy sublayout) (passToServer subserver values) + in route (Proxy :: Proxy sublayout) context (passToServer subserver values) where paramname = cs $ symbolVal (Proxy :: Proxy sym) looksLikeParam (name, _) = name == paramname || name == (paramname <> "[]") convert Nothing = Nothing @@ -538,19 +330,19 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer sublayout) -- > server = getBooks -- > where getBooks :: Bool -> ExceptT ServantErr IO [Book] -- > getBooks onlyPublished = ...return all books, or only the ones that are already published, depending on the argument... -instance (KnownSymbol sym, HasServer sublayout) - => HasServer (QueryFlag sym :> sublayout) where +instance (KnownSymbol sym, HasServer sublayout context) + => HasServer (QueryFlag sym :> sublayout) context where type ServerT (QueryFlag sym :> sublayout) m = Bool -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> + route Proxy context subserver = WithRequest $ \ request -> let querytext = parseQueryText $ rawQueryString request param = case lookup paramname querytext of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value Nothing -> False -- param not in the query string - in route (Proxy :: Proxy sublayout) (passToServer subserver param) + in route (Proxy :: Proxy sublayout) context (passToServer subserver param) where paramname = cs $ symbolVal (Proxy :: Proxy sym) examine v | v == "true" || v == "1" || v == "" = True | otherwise = False @@ -563,11 +355,11 @@ instance (KnownSymbol sym, HasServer sublayout) -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" -instance HasServer Raw where +instance HasServer Raw context where type ServerT Raw m = Application - route Proxy rawApplication = LeafRouter $ \ request respond -> do + route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication case r of Route app -> app request (respond . Route) @@ -595,14 +387,14 @@ instance HasServer Raw where -- > server = postBook -- > where postBook :: Book -> ExceptT ServantErr IO Book -- > postBook book = ...insert into your db... -instance ( AllCTUnrender list a, HasServer sublayout - ) => HasServer (ReqBody list a :> sublayout) where +instance ( AllCTUnrender list a, HasServer sublayout context + ) => HasServer (ReqBody list a :> sublayout) context where type ServerT (ReqBody list a :> sublayout) m = a -> ServerT sublayout m - route Proxy subserver = WithRequest $ \ request -> - route (Proxy :: Proxy sublayout) (addBodyCheck subserver (bodyCheck request)) + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy sublayout) context (addBodyCheck subserver (bodyCheck request)) where bodyCheck request = do -- See HTTP RFC 2616, section 7.2.1 @@ -620,40 +412,58 @@ instance ( AllCTUnrender list a, HasServer sublayout -- | Make sure the incoming request starts with @"/path"@, strip it and -- pass the rest of the request path to @sublayout@. -instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where +instance (KnownSymbol path, HasServer sublayout context) => HasServer (path :> sublayout) context where type ServerT (path :> sublayout) m = ServerT sublayout m - route Proxy subserver = StaticRouter $ + route Proxy context subserver = StaticRouter $ M.singleton (cs (symbolVal proxyPath)) - (route (Proxy :: Proxy sublayout) subserver) + (route (Proxy :: Proxy sublayout) context subserver) where proxyPath = Proxy :: Proxy path -instance HasServer api => HasServer (RemoteHost :> api) where +instance HasServer api context => HasServer (RemoteHost :> api) context where type ServerT (RemoteHost :> api) m = SockAddr -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ remoteHost req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ remoteHost req) -instance HasServer api => HasServer (IsSecure :> api) where +instance HasServer api context => HasServer (IsSecure :> api) context where type ServerT (IsSecure :> api) m = IsSecure -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ secure req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ secure req) where secure req = if isSecure req then Secure else NotSecure -instance HasServer api => HasServer (Vault :> api) where +instance HasServer api context => HasServer (Vault :> api) context where type ServerT (Vault :> api) m = Vault -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ vault req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ vault req) -instance HasServer api => HasServer (HttpVersion :> api) where +instance HasServer api context => HasServer (HttpVersion :> api) context where type ServerT (HttpVersion :> api) m = HttpVersion -> ServerT api m - route Proxy subserver = WithRequest $ \req -> - route (Proxy :: Proxy api) (passToServer subserver $ httpVersion req) + route Proxy context subserver = WithRequest $ \req -> + route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req) + +-- | Basic Authentication +instance ( KnownSymbol realm + , HasServer api context + , HasContextEntry context (BasicAuthCheck usr) + ) + => HasServer (BasicAuth realm usr :> api) context where + + type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m + + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) + where + realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) + basicAuthContext = getContextEntry context + authCheck req = runBasicAuth req realm basicAuthContext + +-- * helpers pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo @@ -663,3 +473,23 @@ pathIsEmpty = go . pathInfo ct_wildcard :: B.ByteString ct_wildcard = "*" <> "/" <> "*" -- Because CPP + +-- * General Authentication + + +-- * contexts + +instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) + => HasServer (WithNamedContext name subContext subApi) context where + + type ServerT (WithNamedContext name subContext subApi) m = + ServerT subApi m + + route Proxy context delayed = + route subProxy subContext delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subContext :: Context subContext + subContext = descendIntoNamedContext (Proxy :: Proxy name) context diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs new file mode 100644 index 00000000..f941f401 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/BasicAuth.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Servant.Server.Internal.BasicAuth where + +import Control.Monad (guard) +import qualified Data.ByteString as BS +import Data.ByteString.Base64 (decodeLenient) +import Data.Monoid ((<>)) +import Data.Typeable (Typeable) +import Data.Word8 (isSpace, toLower, _colon) +import GHC.Generics +import Network.HTTP.Types (Header) +import Network.Wai (Request, requestHeaders) + +import Servant.API.BasicAuth (BasicAuthData(BasicAuthData)) +import Servant.Server.Internal.RoutingApplication +import Servant.Server.Internal.ServantErr + +-- * Basic Auth + +-- | servant-server's current implementation of basic authentication is not +-- immune to certian kinds of timing attacks. Decoding payloads does not take +-- a fixed amount of time. + +-- | The result of authentication/authorization +data BasicAuthResult usr + = Unauthorized + | BadPassword + | NoSuchUser + | Authorized usr + deriving (Eq, Show, Read, Generic, Typeable, Functor) + +-- | Datatype wrapping a function used to check authentication. +newtype BasicAuthCheck usr = BasicAuthCheck + { unBasicAuthCheck :: BasicAuthData + -> IO (BasicAuthResult usr) + } + deriving (Generic, Typeable, Functor) + +-- | Internal method to make a basic-auth challenge +mkBAChallengerHdr :: BS.ByteString -> Header +mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"") + +-- | Find and decode an 'Authorization' header from the request as Basic Auth +decodeBAHdr :: Request -> Maybe BasicAuthData +decodeBAHdr req = do + ah <- lookup "Authorization" $ requestHeaders req + let (b, rest) = BS.break isSpace ah + guard (BS.map toLower b == "basic") + let decoded = decodeLenient (BS.dropWhile isSpace rest) + let (username, passWithColonAtHead) = BS.break (== _colon) decoded + (_, password) <- BS.uncons passWithColonAtHead + return (BasicAuthData username password) + +-- | Run and check basic authentication, returning the appropriate http error per +-- the spec. +runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr) +runBasicAuth req realm (BasicAuthCheck ba) = + case decodeBAHdr req of + Nothing -> plzAuthenticate + Just e -> ba e >>= \res -> case res of + BadPassword -> plzAuthenticate + NoSuchUser -> plzAuthenticate + Unauthorized -> return $ Fail err403 + Authorized usr -> return $ Route usr + where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] } diff --git a/servant-server/src/Servant/Server/Internal/Context.hs b/servant-server/src/Servant/Server/Internal/Context.hs new file mode 100644 index 00000000..580a7542 --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Context.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +#include "overlapping-compat.h" + +module Servant.Server.Internal.Context where + +import Data.Proxy +import GHC.TypeLits + +-- | 'Context's are used to pass values to combinators. (They are __not__ meant +-- to be used to pass parameters to your handlers, i.e. they should not replace +-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using +-- with 'Servant.Server.Internal.Enter.enter'.) If you don't use combinators that +-- require any context entries, you can just use 'Servant.Server.serve' as always. +-- +-- If you are using combinators that require a non-empty 'Context' you have to +-- use 'Servant.Server.serveWithContext' and pass it a 'Context' that contains all +-- the values your combinators need. A 'Context' is essentially a heterogenous +-- list and accessing the elements is being done by type (see 'getContextEntry'). +-- The parameter of the type 'Context' is a type-level list reflecting the types +-- of the contained context entries. To create a 'Context' with entries, use the +-- operator @(':.')@: +-- +-- >>> :type True :. () :. EmptyContext +-- True :. () :. EmptyContext :: Context '[Bool, ()] +data Context contextTypes where + EmptyContext :: Context '[] + (:.) :: x -> Context xs -> Context (x ': xs) +infixr 5 :. + +instance Show (Context '[]) where + show EmptyContext = "EmptyContext" +instance (Show a, Show (Context as)) => Show (Context (a ': as)) where + showsPrec outerPrecedence (a :. as) = + showParen (outerPrecedence > 5) $ + shows a . showString " :. " . shows as + +instance Eq (Context '[]) where + _ == _ = True +instance (Eq a, Eq (Context as)) => Eq (Context (a ': as)) where + x1 :. y1 == x2 :. y2 = x1 == x2 && y1 == y2 + +-- | This class is used to access context entries in 'Context's. 'getContextEntry' +-- returns the first value where the type matches: +-- +-- >>> getContextEntry (True :. False :. EmptyContext) :: Bool +-- True +-- +-- If the 'Context' does not contain an entry of the requested type, you'll get +-- an error: +-- +-- >>> getContextEntry (True :. False :. EmptyContext) :: String +-- ... +-- No instance for (HasContextEntry '[] [Char]) +-- ... +class HasContextEntry (context :: [*]) (val :: *) where + getContextEntry :: Context context -> val + +instance OVERLAPPABLE_ + HasContextEntry xs val => HasContextEntry (notIt ': xs) val where + getContextEntry (_ :. xs) = getContextEntry xs + +instance OVERLAPPING_ + HasContextEntry (val ': xs) val where + getContextEntry (x :. _) = x + +-- * support for named subcontexts + +-- | Normally context entries are accessed by their types. In case you need +-- to have multiple values of the same type in your 'Context' and need to access +-- them, we provide 'NamedContext'. You can think of it as sub-namespaces for +-- 'Context's. +data NamedContext (name :: Symbol) (subContext :: [*]) + = NamedContext (Context subContext) + +-- | 'descendIntoNamedContext' allows you to access `NamedContext's. Usually you +-- won't have to use it yourself but instead use a combinator like +-- 'Servant.API.WithNamedContext.WithNamedContext'. +-- +-- This is how 'descendIntoNamedContext' works: +-- +-- >>> :set -XFlexibleContexts +-- >>> let subContext = True :. EmptyContext +-- >>> :type subContext +-- subContext :: Context '[Bool] +-- >>> let parentContext = False :. (NamedContext subContext :: NamedContext "subContext" '[Bool]) :. EmptyContext +-- >>> :type parentContext +-- parentContext :: Context '[Bool, NamedContext "subContext" '[Bool]] +-- >>> descendIntoNamedContext (Proxy :: Proxy "subContext") parentContext :: Context '[Bool] +-- True :. EmptyContext +descendIntoNamedContext :: forall context name subContext . + HasContextEntry context (NamedContext name subContext) => + Proxy (name :: Symbol) -> Context context -> Context subContext +descendIntoNamedContext Proxy context = + let NamedContext subContext = getContextEntry context :: NamedContext name subContext + in subContext diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs index 5bcebe9d..f1c88b2e 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -10,9 +10,6 @@ {-# LANGUAGE UndecidableInstances #-} module Servant.Server.Internal.Enter where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif import qualified Control.Category as C #if MIN_VERSION_mtl(2,2,1) import Control.Monad.Except @@ -25,6 +22,9 @@ import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter import Data.Typeable +import Prelude () +import Prelude.Compat + import Servant.API class Enter typ arg ret | typ arg -> ret, typ ret -> arg where diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 4b27c688..7d0c4341 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -4,21 +4,15 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} module Servant.Server.Internal.RoutingApplication where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Control.Monad.Trans.Except (ExceptT, runExceptT) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.IORef (newIORef, readIORef, - writeIORef) import Network.Wai (Application, Request, - Response, ResponseReceived, - requestBody, - strictRequestBody) + Response, ResponseReceived) +import Prelude () +import Prelude.Compat import Servant.Server.Internal.ServantErr type RoutingApplication = @@ -33,34 +27,8 @@ data RouteResult a = | Route !a deriving (Eq, Show, Read, Functor) -data ReqBodyState = Uncalled - | Called !B.ByteString - | Done !B.ByteString - toApplication :: RoutingApplication -> Application -toApplication ra request respond = do - reqBodyRef <- newIORef Uncalled - -- We may need to consume the requestBody more than once. In order to - -- maintain the illusion that 'requestBody' works as expected, - -- 'ReqBodyState' is introduced, and the complete body is memoized and - -- returned as many times as requested with empty "Done" marker chunks in - -- between. - -- See https://github.com/haskell-servant/servant/issues/3 - let memoReqBody = do - ior <- readIORef reqBodyRef - case ior of - Uncalled -> do - r <- BL.toStrict <$> strictRequestBody request - writeIORef reqBodyRef $ Done r - return r - Called bs -> do - writeIORef reqBodyRef $ Done bs - return bs - Done bs -> do - writeIORef reqBodyRef $ Called bs - return B.empty - - ra request{ requestBody = memoReqBody } routingRespond +toApplication ra request respond = ra request routingRespond where routingRespond :: RouteResult Response -> IO ResponseReceived routingRespond (Fail err) = respond $ responseServantErr err @@ -77,13 +45,14 @@ toApplication ra request respond = do -- now, and therefore get 415 before 405, which is wrong. -- -- If we delay Captures, but perform method checks eagerly, we --- end up potentially preferring 405 over 404, whcih is also bad. +-- end up potentially preferring 405 over 404, which is also bad. -- -- So in principle, we'd like: -- -- static routes (can cause 404) -- delayed captures (can cause 404) -- methods (can cause 405) +-- authentication and authorization (can cause 401, 403) -- delayed body (can cause 415, 400) -- accept header (can cause 406) -- @@ -98,10 +67,10 @@ toApplication ra request respond = do -- -- There are two reasons: -- --- 1. Currently, the order in which we perform checks coincides --- with the error we will generate. This is because during checks, --- once an error occurs, we do not perform any subsequent checks, --- but rather return this error. +-- 1. In a straight-forward implementation, the order in which we +-- perform checks will determine the error we generate. This is +-- because once an error occurs, we would abort and not perform +-- any subsequent checks, but rather return the current error. -- -- This is not a necessity: we could continue doing other checks, -- and choose the preferred error. However, that would in general @@ -151,36 +120,71 @@ toApplication ra request respond = do -- The accept header check can be performed as the final -- computation in this block. It can cause a 406. -- -data Delayed :: * -> * where - Delayed :: IO (RouteResult a) - -> IO (RouteResult ()) - -> IO (RouteResult b) - -> (a -> b -> RouteResult c) - -> Delayed c +data Delayed c where + Delayed :: { capturesD :: IO (RouteResult captures) + , methodD :: IO (RouteResult ()) + , authD :: IO (RouteResult auth) + , bodyD :: IO (RouteResult body) + , serverD :: (captures -> auth -> body -> RouteResult c) + } -> Delayed c instance Functor Delayed where - fmap f (Delayed a b c g) = Delayed a b c ((fmap.fmap.fmap) f g) + fmap f Delayed{..} + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = bodyD + , serverD = (fmap.fmap.fmap.fmap) f serverD + } -- Note [Existential Record Update] -- | Add a capture to the end of the capture block. addCapture :: Delayed (a -> b) -> IO (RouteResult a) -> Delayed b -addCapture (Delayed captures method body server) new = - Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y) +addCapture Delayed{..} new + = Delayed { capturesD = combineRouteResults (,) capturesD new + , methodD = methodD + , authD = authD + , bodyD = bodyD + , serverD = \ (x, v) y z -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] -- | Add a method check to the end of the method block. addMethodCheck :: Delayed a -> IO (RouteResult ()) -> Delayed a -addMethodCheck (Delayed captures method body server) new = - Delayed captures (combineRouteResults const method new) body server +addMethodCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = combineRouteResults const methodD new + , authD = authD + , bodyD = bodyD + , serverD = serverD + } -- Note [Existential Record Update] + +-- | Add an auth check to the end of the auth block. +addAuthCheck :: Delayed (a -> b) + -> IO (RouteResult a) + -> Delayed b +addAuthCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = combineRouteResults (,) authD new + , bodyD = bodyD + , serverD = \ x (y, v) z -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] -- | Add a body check to the end of the body block. addBodyCheck :: Delayed (a -> b) -> IO (RouteResult a) -> Delayed b -addBodyCheck (Delayed captures method body server) new = - Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y) +addBodyCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = combineRouteResults (,) bodyD new + , serverD = \ x y (z, v) -> ($ v) <$> serverD x y z + } -- Note [Existential Record Update] + -- | Add an accept header check to the end of the body block. -- The accept header check should occur after the body check, @@ -189,8 +193,13 @@ addBodyCheck (Delayed captures method body server) new = addAcceptCheck :: Delayed a -> IO (RouteResult ()) -> Delayed a -addAcceptCheck (Delayed captures method body server) new = - Delayed captures method (combineRouteResults const body new) server +addAcceptCheck Delayed{..} new + = Delayed { capturesD = capturesD + , methodD = methodD + , authD = authD + , bodyD = combineRouteResults const bodyD new + , serverD = serverD + } -- Note [Existential Record Update] -- | Many combinators extract information that is passed to -- the handler without the possibility of failure. In such a @@ -222,13 +231,17 @@ combineRouteResults f m1 m2 = -- | Run a delayed server. Performs all scheduled operations -- in order, and passes the results from the capture and body -- blocks on to the actual handler. +-- +-- This should only be called once per request; otherwise the guarantees about +-- effect and HTTP error ordering break down. runDelayed :: Delayed a -> IO (RouteResult a) -runDelayed (Delayed captures method body server) = - captures `bindRouteResults` \ c -> - method `bindRouteResults` \ _ -> - body `bindRouteResults` \ b -> - return (server c b) +runDelayed Delayed{..} = + capturesD `bindRouteResults` \ c -> + methodD `bindRouteResults` \ _ -> + authD `bindRouteResults` \ a -> + bodyD `bindRouteResults` \ b -> + return (serverD c a b) -- | Runs a delayed server and the resulting action. -- Takes a continuation that lets us send a response. @@ -240,10 +253,17 @@ runAction :: Delayed (ExceptT ServantErr IO a) -> IO r runAction action respond k = runDelayed action >>= go >>= respond where - go (Fail e) = return $ Fail e + go (Fail e) = return $ Fail e go (FailFatal e) = return $ FailFatal e - go (Route a) = do + go (Route a) = do e <- runExceptT a case e of Left err -> return . Route $ responseServantErr err Right x -> return $! k x + +{- Note [Existential Record Update] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Due to GHC issue , we cannot +do the more succint thing - just update the records we actually change. +-} diff --git a/servant-server/src/Servant/Server/Internal/ServantErr.hs b/servant-server/src/Servant/Server/Internal/ServantErr.hs index 6cfa3e90..4e646a7a 100644 --- a/servant-server/src/Servant/Server/Internal/ServantErr.hs +++ b/servant-server/src/Servant/Server/Internal/ServantErr.hs @@ -1,9 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} module Servant.Server.Internal.ServantErr where +import Control.Exception (Exception) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS +import Data.Typeable (Typeable) import qualified Network.HTTP.Types as HTTP import Network.Wai (Response, responseLBS) @@ -11,13 +14,22 @@ data ServantErr = ServantErr { errHTTPCode :: Int , errReasonPhrase :: String , errBody :: LBS.ByteString , errHeaders :: [HTTP.Header] - } deriving (Show, Eq, Read) + } deriving (Show, Eq, Read, Typeable) + +instance Exception ServantErr responseServantErr :: ServantErr -> Response responseServantErr ServantErr{..} = responseLBS status errHeaders errBody where status = HTTP.mkStatus errHTTPCode (BS.pack errReasonPhrase) +-- | 'err300' Multiple Choices +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err300 { errBody = "I can't choose." } +-- err300 :: ServantErr err300 = ServantErr { errHTTPCode = 300 , errReasonPhrase = "Multiple Choices" @@ -25,6 +37,13 @@ err300 = ServantErr { errHTTPCode = 300 , errHeaders = [] } +-- | 'err301' Moved Permanently +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err301 +-- err301 :: ServantErr err301 = ServantErr { errHTTPCode = 301 , errReasonPhrase = "Moved Permanently" @@ -32,6 +51,13 @@ err301 = ServantErr { errHTTPCode = 301 , errHeaders = [] } +-- | 'err302' Found +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err302 +-- err302 :: ServantErr err302 = ServantErr { errHTTPCode = 302 , errReasonPhrase = "Found" @@ -39,6 +65,13 @@ err302 = ServantErr { errHTTPCode = 302 , errHeaders = [] } +-- | 'err303' See Other +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err303 +-- err303 :: ServantErr err303 = ServantErr { errHTTPCode = 303 , errReasonPhrase = "See Other" @@ -46,6 +79,13 @@ err303 = ServantErr { errHTTPCode = 303 , errHeaders = [] } +-- | 'err304' Not Modified +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err304 +-- err304 :: ServantErr err304 = ServantErr { errHTTPCode = 304 , errReasonPhrase = "Not Modified" @@ -53,6 +93,13 @@ err304 = ServantErr { errHTTPCode = 304 , errHeaders = [] } +-- | 'err305' Use Proxy +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err305 +-- err305 :: ServantErr err305 = ServantErr { errHTTPCode = 305 , errReasonPhrase = "Use Proxy" @@ -60,6 +107,13 @@ err305 = ServantErr { errHTTPCode = 305 , errHeaders = [] } +-- | 'err307' Temporary Redirect +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err307 +-- err307 :: ServantErr err307 = ServantErr { errHTTPCode = 307 , errReasonPhrase = "Temporary Redirect" @@ -67,6 +121,13 @@ err307 = ServantErr { errHTTPCode = 307 , errHeaders = [] } +-- | 'err400' Bad Request +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err400 { errBody = "Your request makes no sense to me." } +-- err400 :: ServantErr err400 = ServantErr { errHTTPCode = 400 , errReasonPhrase = "Bad Request" @@ -74,6 +135,13 @@ err400 = ServantErr { errHTTPCode = 400 , errHeaders = [] } +-- | 'err401' Unauthorized +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err401 { errBody = "Your credentials are invalid." } +-- err401 :: ServantErr err401 = ServantErr { errHTTPCode = 401 , errReasonPhrase = "Unauthorized" @@ -81,6 +149,13 @@ err401 = ServantErr { errHTTPCode = 401 , errHeaders = [] } +-- | 'err402' Payment Required +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err402 { errBody = "You have 0 credits. Please give me $$$." } +-- err402 :: ServantErr err402 = ServantErr { errHTTPCode = 402 , errReasonPhrase = "Payment Required" @@ -88,6 +163,13 @@ err402 = ServantErr { errHTTPCode = 402 , errHeaders = [] } +-- | 'err403' Forbidden +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err403 { errBody = "Please login first." } +-- err403 :: ServantErr err403 = ServantErr { errHTTPCode = 403 , errReasonPhrase = "Forbidden" @@ -95,6 +177,13 @@ err403 = ServantErr { errHTTPCode = 403 , errHeaders = [] } +-- | 'err404' Not Found +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err404 { errBody = "(╯°□°）╯︵ ┻━┻)." } +-- err404 :: ServantErr err404 = ServantErr { errHTTPCode = 404 , errReasonPhrase = "Not Found" @@ -102,6 +191,13 @@ err404 = ServantErr { errHTTPCode = 404 , errHeaders = [] } +-- | 'err405' Method Not Allowed +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err405 { errBody = "Your account privileges does not allow for this. Please pay $$$." } +-- err405 :: ServantErr err405 = ServantErr { errHTTPCode = 405 , errReasonPhrase = "Method Not Allowed" @@ -109,6 +205,13 @@ err405 = ServantErr { errHTTPCode = 405 , errHeaders = [] } +-- | 'err406' Not Acceptable +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err406 +-- err406 :: ServantErr err406 = ServantErr { errHTTPCode = 406 , errReasonPhrase = "Not Acceptable" @@ -116,6 +219,13 @@ err406 = ServantErr { errHTTPCode = 406 , errHeaders = [] } +-- | 'err407' Proxy Authentication Required +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err407 +-- err407 :: ServantErr err407 = ServantErr { errHTTPCode = 407 , errReasonPhrase = "Proxy Authentication Required" @@ -123,6 +233,13 @@ err407 = ServantErr { errHTTPCode = 407 , errHeaders = [] } +-- | 'err409' Conflict +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err409 { errBody = "Transaction conflicts with 59879cb56c7c159231eeacdd503d755f7e835f74" } +-- err409 :: ServantErr err409 = ServantErr { errHTTPCode = 409 , errReasonPhrase = "Conflict" @@ -130,6 +247,13 @@ err409 = ServantErr { errHTTPCode = 409 , errHeaders = [] } +-- | 'err410' Gone +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err410 { errBody = "I know it was here at some point, but.. I blame bad luck." } +-- err410 :: ServantErr err410 = ServantErr { errHTTPCode = 410 , errReasonPhrase = "Gone" @@ -137,6 +261,13 @@ err410 = ServantErr { errHTTPCode = 410 , errHeaders = [] } +-- | 'err411' Length Required +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr err411 +-- err411 :: ServantErr err411 = ServantErr { errHTTPCode = 411 , errReasonPhrase = "Length Required" @@ -144,6 +275,13 @@ err411 = ServantErr { errHTTPCode = 411 , errHeaders = [] } +-- | 'err412' Precondition Failed +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err412 { errBody = "Precondition fail: x < 42 && y > 57" } +-- err412 :: ServantErr err412 = ServantErr { errHTTPCode = 412 , errReasonPhrase = "Precondition Failed" @@ -151,6 +289,13 @@ err412 = ServantErr { errHTTPCode = 412 , errHeaders = [] } +-- | 'err413' Request Entity Too Large +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err413 { errBody = "Request exceeded 64k." } +-- err413 :: ServantErr err413 = ServantErr { errHTTPCode = 413 , errReasonPhrase = "Request Entity Too Large" @@ -158,6 +303,13 @@ err413 = ServantErr { errHTTPCode = 413 , errHeaders = [] } +-- | 'err414' Request-URI Too Large +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err414 { errBody = "Maximum length is 64." } +-- err414 :: ServantErr err414 = ServantErr { errHTTPCode = 414 , errReasonPhrase = "Request-URI Too Large" @@ -165,6 +317,13 @@ err414 = ServantErr { errHTTPCode = 414 , errHeaders = [] } +-- | 'err415' Unsupported Media Type +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err415 { errBody = "Supported media types: gif, png" } +-- err415 :: ServantErr err415 = ServantErr { errHTTPCode = 415 , errReasonPhrase = "Unsupported Media Type" @@ -172,6 +331,13 @@ err415 = ServantErr { errHTTPCode = 415 , errHeaders = [] } +-- | 'err416' Request range not satisfiable +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err416 { errBody = "Valid range is [0, 424242]." } +-- err416 :: ServantErr err416 = ServantErr { errHTTPCode = 416 , errReasonPhrase = "Request range not satisfiable" @@ -179,6 +345,13 @@ err416 = ServantErr { errHTTPCode = 416 , errHeaders = [] } +-- | 'err417' Expectation Failed +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err417 { errBody = "I found a quux in the request. This isn't going to work." } +-- err417 :: ServantErr err417 = ServantErr { errHTTPCode = 417 , errReasonPhrase = "Expectation Failed" @@ -186,6 +359,13 @@ err417 = ServantErr { errHTTPCode = 417 , errHeaders = [] } +-- | 'err500' Internal Server Error +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err500 { errBody = "Exception in module A.B.C:55. Have a great day!" } +-- err500 :: ServantErr err500 = ServantErr { errHTTPCode = 500 , errReasonPhrase = "Internal Server Error" @@ -193,6 +373,13 @@ err500 = ServantErr { errHTTPCode = 500 , errHeaders = [] } +-- | 'err501' Not Implemented +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err501 { errBody = "/v1/foo is not supported with quux in the request." } +-- err501 :: ServantErr err501 = ServantErr { errHTTPCode = 501 , errReasonPhrase = "Not Implemented" @@ -200,6 +387,13 @@ err501 = ServantErr { errHTTPCode = 501 , errHeaders = [] } +-- | 'err502' Bad Gateway +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err502 { errBody = "Tried gateway foo, bar, and baz. None responded." } +-- err502 :: ServantErr err502 = ServantErr { errHTTPCode = 502 , errReasonPhrase = "Bad Gateway" @@ -207,6 +401,13 @@ err502 = ServantErr { errHTTPCode = 502 , errHeaders = [] } +-- | 'err503' Service Unavailable +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err503 { errBody = "We're rewriting in PHP." } +-- err503 :: ServantErr err503 = ServantErr { errHTTPCode = 503 , errReasonPhrase = "Service Unavailable" @@ -214,6 +415,13 @@ err503 = ServantErr { errHTTPCode = 503 , errHeaders = [] } +-- | 'err504' Gateway Time-out +-- +-- Example: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err504 { errBody = "Backend foobar did not respond in 5 seconds." } +-- err504 :: ServantErr err504 = ServantErr { errHTTPCode = 504 , errReasonPhrase = "Gateway Time-out" @@ -221,6 +429,13 @@ err504 = ServantErr { errHTTPCode = 504 , errHeaders = [] } +-- | 'err505' HTTP Version not supported +-- +-- Example usage: +-- +-- > failingHandler :: ExceptT ServantErr IO () +-- > failingHandler = throwErr $ err505 { errBody = "I support HTTP/4.0 only." } +-- err505 :: ServantErr err505 = ServantErr { errHTTPCode = 505 , errReasonPhrase = "HTTP Version not supported" diff --git a/servant-server/test/Doctests.hs b/servant-server/test/Doctests.hs index 572461aa..663f8768 100644 --- a/servant-server/test/Doctests.hs +++ b/servant-server/test/Doctests.hs @@ -10,7 +10,7 @@ main :: IO () main = do files <- find always (extension ==? ".hs") "src" mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : + doctest $ "-isrc" : "-Iinclude" : (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ "-XOverloadedStrings" : "-XFlexibleInstances" : diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 2e93cc2a..94d26d09 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Servant.Server.ErrorSpec (spec) where @@ -10,7 +11,8 @@ import Data.Aeson (encode) import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BCL import Data.Proxy -import Network.HTTP.Types (hAccept, hContentType, methodGet, +import Network.HTTP.Types (hAccept, hAuthorization, + hContentType, methodGet, methodPost, methodPut) import Safe (readMay) import Test.Hspec @@ -25,57 +27,79 @@ spec = describe "HTTP Errors" $ do errorRetrySpec errorChoiceSpec +-- * Auth machinery (reused throughout) + +-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. +errorOrderAuthCheck :: BasicAuthCheck () +errorOrderAuthCheck = + let check (BasicAuthData username password) = + if username == "servant" && password == "server" + then return (Authorized ()) + else return Unauthorized + in BasicAuthCheck check + ------------------------------------------------------------------------------ -- * Error Order {{{ type ErrorOrderApi = "home" + :> BasicAuth "error-realm" () :> ReqBody '[JSON] Int :> Capture "t" Int :> Post '[JSON] Int - errorOrderApi :: Proxy ErrorOrderApi errorOrderApi = Proxy errorOrderServer :: Server ErrorOrderApi -errorOrderServer = \_ _ -> throwE err402 +errorOrderServer = \_ _ _ -> throwE err402 errorOrderSpec :: Spec -errorOrderSpec = describe "HTTP error order" - $ with (return $ serve errorOrderApi errorOrderServer) $ do +errorOrderSpec = + describe "HTTP error order" $ + with (return $ serveWithContext errorOrderApi + (errorOrderAuthCheck :. EmptyContext) + errorOrderServer + ) $ do let badContentType = (hContentType, "text/plain") badAccept = (hAccept, "text/plain") badMethod = methodGet - badUrl = "home/nonexistent" + badUrl = "nonexistent" badBody = "nonsense" + badAuth = (hAuthorization, "Basic foofoofoo") goodContentType = (hContentType, "application/json") goodAccept = (hAccept, "application/json") goodMethod = methodPost goodUrl = "home/2" goodBody = encode (5 :: Int) + -- username:password = servant:server + goodAuth = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=") it "has 404 as its highest priority error" $ do - request badMethod badUrl [badContentType, badAccept] badBody + request badMethod badUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 404 it "has 405 as its second highest priority error" $ do - request badMethod goodUrl [badContentType, badAccept] badBody + request badMethod goodUrl [badAuth, badContentType, badAccept] badBody `shouldRespondWith` 405 - it "has 415 as its third highest priority error" $ do - request goodMethod goodUrl [badContentType, badAccept] badBody + it "has 401 as its third highest priority error (auth)" $ do + request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody + `shouldRespondWith` 401 + + it "has 415 as its fourth highest priority error" $ do + request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody `shouldRespondWith` 415 - it "has 400 as its fourth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] badBody + it "has 400 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody `shouldRespondWith` 400 - it "has 406 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] goodBody + it "has 406 as its sixth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody `shouldRespondWith` 406 it "has handler-level errors as last priority" $ do - request goodMethod goodUrl [goodContentType, goodAccept] goodBody + request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody `shouldRespondWith` 402 type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer @@ -134,9 +158,12 @@ type ErrorRetryApi :<|> "a" :> ReqBody '[JSON] Int :> Post '[PlainText] Int -- 2 :<|> "a" :> ReqBody '[JSON] String :> Post '[JSON] Int -- 3 :<|> "a" :> ReqBody '[JSON] Int :> Get '[JSON] Int -- 4 - :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 - :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6 - :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7 + :<|> "a" :> BasicAuth "bar-realm" () + :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 + :<|> "a" :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 6 + + :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 7 + :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 8 errorRetryApi :: Proxy ErrorRetryApi errorRetryApi = Proxy @@ -148,13 +175,18 @@ errorRetryServer :<|> (\_ -> return 2) :<|> (\_ -> return 3) :<|> (\_ -> return 4) - :<|> (\_ -> return 5) + :<|> (\_ _ -> return 5) :<|> (\_ -> return 6) :<|> (\_ -> return 7) + :<|> (\_ -> return 8) errorRetrySpec :: Spec -errorRetrySpec = describe "Handler search" - $ with (return $ serve errorRetryApi errorRetryServer) $ do +errorRetrySpec = + describe "Handler search" $ + with (return $ serveWithContext errorRetryApi + (errorOrderAuthCheck :. EmptyContext) + errorRetryServer + ) $ do let jsonCT = (hContentType, "application/json") jsonAccept = (hAccept, "application/json") @@ -162,7 +194,7 @@ errorRetrySpec = describe "Handler search" it "should continue when URLs don't match" $ do request methodPost "" [jsonCT, jsonAccept] jsonBody - `shouldRespondWith` 201 { matchBody = Just $ encode (7 :: Int) } + `shouldRespondWith` 200 { matchBody = Just $ encode (8 :: Int) } it "should continue when methods don't match" $ do request methodGet "a" [jsonCT, jsonAccept] jsonBody diff --git a/servant-server/test/Servant/Server/Internal/ContextSpec.hs b/servant-server/test/Servant/Server/Internal/ContextSpec.hs new file mode 100644 index 00000000..dfac1e2e --- /dev/null +++ b/servant-server/test/Servant/Server/Internal/ContextSpec.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fdefer-type-errors #-} +module Servant.Server.Internal.ContextSpec (spec) where + +import Data.Proxy (Proxy (..)) +import Test.Hspec (Spec, describe, it, shouldBe, pending, context) +import Test.ShouldNotTypecheck (shouldNotTypecheck) + +import Servant.API +import Servant.Server.Internal.Context + +spec :: Spec +spec = do + describe "getContextEntry" $ do + it "gets the context if a matching one exists" $ do + let cxt = 'a' :. EmptyContext + getContextEntry cxt `shouldBe` 'a' + + it "gets the first matching context" $ do + let cxt = 'a' :. 'b' :. EmptyContext + getContextEntry cxt `shouldBe` 'a' + + it "does not typecheck if type does not exist" $ do + let cxt = 'a' :. EmptyContext + x = getContextEntry cxt :: Bool + shouldNotTypecheck x + + context "Show instance" $ do + let cxt = 'a' :. True :. EmptyContext + it "has a Show instance" $ do + show cxt `shouldBe` "'a' :. True :. EmptyContext" + + context "bracketing" $ do + it "works" $ do + show (Just cxt) `shouldBe` "Just ('a' :. True :. EmptyContext)" + + it "works with operators" $ do + let cxt = (1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext) + show cxt `shouldBe` "(1 :. 'a' :. EmptyContext) :<|> ('b' :. True :. EmptyContext)" + + describe "descendIntoNamedContext" $ do + let cxt :: Context [Char, NamedContext "sub" '[Char]] + cxt = + 'a' :. + (NamedContext subContext :: NamedContext "sub" '[Char]) + :. EmptyContext + subContext = 'b' :. EmptyContext + it "allows extracting subcontexts" $ do + descendIntoNamedContext (Proxy :: Proxy "sub") cxt `shouldBe` subContext + + it "allows extracting entries from subcontexts" $ do + getContextEntry (descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Char]) + `shouldBe` 'b' + + it "does not typecheck if subContext has the wrong type" $ do + let x = descendIntoNamedContext (Proxy :: Proxy "sub") cxt :: Context '[Int] + shouldNotTypecheck (show x) + + it "does not typecheck if subContext with that name doesn't exist" $ do + let x = descendIntoNamedContext (Proxy :: Proxy "foo") cxt :: Context '[Char] + shouldNotTypecheck (show x) diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 973e1f89..8b450377 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -52,7 +52,7 @@ enterSpec = describe "Enter" $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" - post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 201 } + post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } with (return (serve combinedAPI combinedReaderServer)) $ do it "allows combnation of enters" $ do diff --git a/servant-server/test/Servant/Server/StreamingSpec.hs b/servant-server/test/Servant/Server/StreamingSpec.hs new file mode 100644 index 00000000..3752df49 --- /dev/null +++ b/servant-server/test/Servant/Server/StreamingSpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module tests whether streaming works from client to server +-- with a server implemented with servant-server. +module Servant.Server.StreamingSpec where + +import Control.Concurrent +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Trans.Except +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Internal +import Prelude () +import Prelude.Compat +import Servant +import qualified System.Timeout +import Test.Hspec + +type TestAPI = + ReqBody '[OctetStream] Lazy.ByteString :> Get '[JSON] NoContent + +testAPI :: Proxy TestAPI +testAPI = Proxy + +spec :: Spec +spec = do + -- The idea of this test is this: + -- + -- - The mock client will + -- - send some data in the request body, but not all, + -- - wait for the server to acknowledge (outside of http, through an MVar) + -- that the server received some data, + -- - send the rest of the request body. + -- - The mock server will + -- - receive some data, + -- - notify the client that it received some data, + -- - receive the rest of the data, + -- - respond with an empty result. + it "client to server can stream lazy ByteStrings" $ timeout $ do + serverReceivedFirstChunk <- newWaiter + + -- - streams some test data + -- - waits for serverReceivedFirstChunk + -- - streams some more test data + streamTestData <- do + mvar :: MVar [IO Strict.ByteString] <- newMVar $ + map return (replicate 1000 "foo") ++ + (waitFor serverReceivedFirstChunk >> return "foo") : + map return (replicate 1000 "foo") + return $ modifyMVar mvar $ \ actions -> case actions of + (a : r) -> (r, ) <$> a + [] -> return ([], "") + + let request = defaultRequest { + requestBody = streamTestData, + requestBodyLength = ChunkedBody + } + + -- - receives the first chunk + -- - notifies serverReceivedFirstChunk + -- - receives the rest of the request + let handler :: Lazy.ByteString -> ExceptT ServantErr IO NoContent + handler input = liftIO $ do + let prefix = Lazy.take 3 input + prefix `shouldBe` "foo" + notify serverReceivedFirstChunk () + input `shouldBe` mconcat (replicate 2001 "foo") + return NoContent + + app = serve testAPI handler + response <- executeRequest app request + statusCode (responseStatus response) `shouldBe` 200 + +executeRequest :: Application -> Request -> IO Response +executeRequest app request = do + responseMVar <- newEmptyMVar + let respond response = do + putMVar responseMVar response + return ResponseReceived + ResponseReceived <- app request respond + takeMVar responseMVar + +timeout :: IO a -> IO a +timeout action = do + result <- System.Timeout.timeout 1000000 action + maybe (throwIO $ ErrorCall "timeout") return result + +-- * waiter + +data Waiter a + = Waiter { + notify :: a -> IO (), + waitFor :: IO a + } + +newWaiter :: IO (Waiter a) +newWaiter = do + mvar <- newEmptyMVar + return $ Waiter { + notify = putMVar mvar, + waitFor = readMVar mvar + } diff --git a/servant-server/test/Servant/Server/UsingContextSpec.hs b/servant-server/test/Servant/Server/UsingContextSpec.hs new file mode 100644 index 00000000..33b04125 --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Servant.Server.UsingContextSpec where + +import Control.Monad.Trans.Except +import Network.Wai +import Test.Hspec (Spec, describe, it) +import Test.Hspec.Wai + +import Servant +import Servant.Server.UsingContextSpec.TestCombinators + +spec :: Spec +spec = do + spec1 + spec2 + spec3 + spec4 + +-- * API + +type OneEntryAPI = + ExtractFromContext :> Get '[JSON] String + +testServer :: String -> ExceptT ServantErr IO String +testServer s = return s + +oneEntryApp :: Application +oneEntryApp = + serveWithContext (Proxy :: Proxy OneEntryAPI) context testServer + where + context :: Context '[String] + context = "contextEntry" :. EmptyContext + +type OneEntryTwiceAPI = + "foo" :> ExtractFromContext :> Get '[JSON] String :<|> + "bar" :> ExtractFromContext :> Get '[JSON] String + +oneEntryTwiceApp :: Application +oneEntryTwiceApp = serveWithContext (Proxy :: Proxy OneEntryTwiceAPI) context $ + testServer :<|> + testServer + where + context :: Context '[String] + context = "contextEntryTwice" :. EmptyContext + +-- * tests + +spec1 :: Spec +spec1 = do + describe "accessing context entries from custom combinators" $ do + with (return oneEntryApp) $ do + it "allows retrieving a ContextEntry" $ do + get "/" `shouldRespondWith` "\"contextEntry\"" + + with (return oneEntryTwiceApp) $ do + it "allows retrieving the same ContextEntry twice" $ do + get "/foo" `shouldRespondWith` "\"contextEntryTwice\"" + get "/bar" `shouldRespondWith` "\"contextEntryTwice\"" + +type InjectAPI = + InjectIntoContext :> "untagged" :> ExtractFromContext :> + Get '[JSON] String :<|> + InjectIntoContext :> "tagged" :> ExtractFromContext :> + Get '[JSON] String + +injectApp :: Application +injectApp = serveWithContext (Proxy :: Proxy InjectAPI) context $ + (\ s -> return s) :<|> + (\ s -> return ("tagged: " ++ s)) + where + context = EmptyContext + +spec2 :: Spec +spec2 = do + with (return injectApp) $ do + describe "inserting context entries with custom combinators" $ do + it "allows to inject context entries" $ do + get "/untagged" `shouldRespondWith` "\"injected\"" + + it "allows to inject tagged context entries" $ do + get "/tagged" `shouldRespondWith` "\"tagged: injected\"" + +type WithBirdfaceAPI = + "foo" :> ExtractFromContext :> Get '[JSON] String :<|> + NamedContextWithBirdface "sub" '[String] :> + "bar" :> ExtractFromContext :> Get '[JSON] String + +withBirdfaceApp :: Application +withBirdfaceApp = serveWithContext (Proxy :: Proxy WithBirdfaceAPI) context $ + testServer :<|> + testServer + where + context :: Context '[String, (NamedContext "sub" '[String])] + context = + "firstEntry" :. + (NamedContext ("secondEntry" :. EmptyContext)) :. + EmptyContext + +spec3 :: Spec +spec3 = do + with (return withBirdfaceApp) $ do + it "allows retrieving different ContextEntries for the same combinator" $ do + get "/foo" `shouldRespondWith` "\"firstEntry\"" + get "/bar" `shouldRespondWith` "\"secondEntry\"" + +type NamedContextAPI = + WithNamedContext "sub" '[String] ( + ExtractFromContext :> Get '[JSON] String) + +namedContextApp :: Application +namedContextApp = serveWithContext (Proxy :: Proxy NamedContextAPI) context return + where + context :: Context '[NamedContext "sub" '[String]] + context = NamedContext ("descend" :. EmptyContext) :. EmptyContext + +spec4 :: Spec +spec4 = do + with (return namedContextApp) $ do + describe "WithNamedContext" $ do + it "allows descending into a subcontext for a given api" $ do + get "/" `shouldRespondWith` "\"descend\"" diff --git a/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs new file mode 100644 index 00000000..48595c9c --- /dev/null +++ b/servant-server/test/Servant/Server/UsingContextSpec/TestCombinators.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | These are custom combinators for Servant.Server.UsingContextSpec. +-- +-- (For writing your own combinators you need to import Internal modules, for +-- just *using* combinators that require a Context, you don't. This module is +-- separate from Servant.Server.UsingContextSpec to test that the module imports +-- work out this way.) +module Servant.Server.UsingContextSpec.TestCombinators where + +import GHC.TypeLits + +import Servant +import Servant.Server.Internal.RoutingApplication + +data ExtractFromContext + +instance (HasContextEntry context String, HasServer subApi context) => + HasServer (ExtractFromContext :> subApi) context where + + type ServerT (ExtractFromContext :> subApi) m = + String -> ServerT subApi m + + route Proxy context delayed = + route subProxy context (fmap (inject context) delayed :: Delayed (Server subApi)) + where + subProxy :: Proxy subApi + subProxy = Proxy + + inject context f = f (getContextEntry context) + +data InjectIntoContext + +instance (HasServer subApi (String ': context)) => + HasServer (InjectIntoContext :> subApi) context where + + type ServerT (InjectIntoContext :> subApi) m = + ServerT subApi m + + route Proxy context delayed = + route subProxy newContext delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + newContext = ("injected" :: String) :. context + +data NamedContextWithBirdface (name :: Symbol) (subContext :: [*]) + +instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext) => + HasServer (NamedContextWithBirdface name subContext :> subApi) context where + + type ServerT (NamedContextWithBirdface name subContext :> subApi) m = + ServerT subApi m + + route Proxy context delayed = + route subProxy subContext delayed + where + subProxy :: Proxy subApi + subProxy = Proxy + + subContext :: Context subContext + subContext = descendIntoNamedContext (Proxy :: Proxy name) context diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index e017d399..5499c804 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -1,19 +1,22 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} module Servant.ServerSpec where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Monad (forM_, when) +import Control.Monad (forM_, when, unless) import Control.Monad.Trans.Except (ExceptT, throwE) import Data.Aeson (FromJSON, ToJSON, decode', encode) import Data.ByteString.Conversion () @@ -23,82 +26,163 @@ import Data.String (fromString) import Data.String.Conversions (cs) import qualified Data.Text as T import GHC.Generics (Generic) -import Network.HTTP.Types (hAccept, hContentType, - methodDelete, methodGet, methodHead, - methodPatch, methodPost, methodPut, - ok200, parseQuery, Status(..)) -import Network.Wai (Application, Request, pathInfo, +import Network.HTTP.Types (Status (..), hAccept, hContentType, + methodDelete, methodGet, + methodHead, methodPatch, + methodPost, methodPut, ok200, + parseQuery) +import Network.Wai (Application, Request, requestHeaders, pathInfo, queryString, rawQueryString, - responseLBS, responseBuilder) -import Network.Wai.Internal (Response(ResponseBuilder)) + responseBuilder, responseLBS) +import Network.Wai.Internal (Response (ResponseBuilder)) import Network.Wai.Test (defaultRequest, request, - runSession, simpleBody) -import Servant.API ((:<|>) (..), (:>), Capture, Delete, - Get, Header (..), Headers, - HttpVersion, IsSecure (..), JSON, - Patch, PlainText, Post, Put, + runSession, simpleBody, + simpleHeaders, simpleStatus) +import Servant.API ((:<|>) (..), (:>), AuthProtect, + BasicAuth, BasicAuthData(BasicAuthData), + Capture, Delete, Get, Header (..), + Headers, HttpVersion, + IsSecure (..), JSON, + NoContent (..), Patch, PlainText, + Post, Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, - addHeader) -import Servant.Server (Server, serve, ServantErr(..), err404) -import Test.Hspec (Spec, describe, it, shouldBe) + StdMethod (..), Verb, addHeader) +import Servant.API.Internal.Test.ComprehensiveAPI +import Servant.Server (ServantErr (..), Server, err401, err404, + serve, serveWithContext, Context((:.), EmptyContext)) +import Test.Hspec (Spec, context, describe, it, + shouldBe, shouldContain) +import qualified Test.Hspec.Wai as THW import Test.Hspec.Wai (get, liftIO, matchHeaders, - matchStatus, post, request, - shouldRespondWith, with, (<:>)) -import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..)) + matchStatus, shouldRespondWith, + with, (<:>)) + +import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), + BasicAuthResult(Authorized,Unauthorized)) +import Servant.Server.Experimental.Auth + (AuthHandler, AuthServerData, + mkAuthHandler) +import Servant.Server.Internal.RoutingApplication + (toApplication, RouteResult(..)) import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) +import Servant.Server.Internal.Context + (NamedContext(..)) +-- * comprehensive api test --- * test data types +-- This declaration simply checks that all instances are in place. +_ = serveWithContext comprehensiveAPI comprehensiveApiContext -data Person = Person { - name :: String, - age :: Integer - } - deriving (Eq, Show, Generic) +comprehensiveApiContext :: Context '[NamedContext "foo" '[]] +comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext -instance ToJSON Person -instance FromJSON Person - -alice :: Person -alice = Person "Alice" 42 - -data Animal = Animal { - species :: String, - numberOfLegs :: Integer - } - deriving (Eq, Show, Generic) - -instance ToJSON Animal -instance FromJSON Animal - -jerry :: Animal -jerry = Animal "Mouse" 4 - -tweety :: Animal -tweety = Animal "Bird" 2 - - --- * specs +-- * Specs spec :: Spec spec = do + verbSpec captureSpec - getSpec - headSpec - postSpec - putSpec - patchSpec queryParamSpec + reqBodySpec headerSpec rawSpec - unionSpec - routerSpec + alternativeSpec responseHeadersSpec - miscReqCombinatorsSpec + routerSpec + miscCombinatorSpec + basicAuthSpec + genAuthSpec +------------------------------------------------------------------------------ +-- * verbSpec {{{ +------------------------------------------------------------------------------ + +type VerbApi method status + = Verb method status '[JSON] Person + :<|> "noContent" :> Verb method status '[JSON] NoContent + :<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person) + :<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent) + +verbSpec :: Spec +verbSpec = describe "Servant.API.Verb" $ do + let server :: Server (VerbApi method status) + server = return alice + :<|> return NoContent + :<|> return (addHeader 5 alice) + :<|> return (addHeader 10 NoContent) + get200 = Proxy :: Proxy (VerbApi 'GET 200) + post210 = Proxy :: Proxy (VerbApi 'POST 210) + put203 = Proxy :: Proxy (VerbApi 'PUT 203) + delete280 = Proxy :: Proxy (VerbApi 'DELETE 280) + patch214 = Proxy :: Proxy (VerbApi 'PATCH 214) + wrongMethod m = if m == methodPatch then methodPost else methodPatch + test desc api method (status :: Int) = context desc $ + + with (return $ serve api server) $ do + + -- HEAD and 214/215 need not return bodies + unless (status `elem` [214, 215] || method == methodHead) $ + it "returns the person" $ do + response <- THW.request method "/" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + + it "returns no content on NoContent" $ do + response <- THW.request method "/noContent" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "" + + -- HEAD should not return body + when (method == methodHead) $ + it "HEAD returns no content body" $ do + response <- THW.request method "/" [] "" + liftIO $ simpleBody response `shouldBe` "" + + it "throws 405 on wrong method " $ do + THW.request (wrongMethod method) "/" [] "" + `shouldRespondWith` 405 + + it "returns headers" $ do + response1 <- THW.request method "/header" [] "" + liftIO $ statusCode (simpleStatus response1) `shouldBe` status + liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")] + + response2 <- THW.request method "/header" [] "" + liftIO $ statusCode (simpleStatus response2) `shouldBe` status + liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")] + + it "handles trailing '/' gracefully" $ do + response <- THW.request method "/headerNC/" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + + it "returns 406 if the Accept header is not supported" $ do + THW.request method "" [(hAccept, "crazy/mime")] "" + `shouldRespondWith` 406 + + it "responds if the Accept header is supported" $ do + response <- THW.request method "" + [(hAccept, "application/json")] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + + it "sets the Content-Type header" $ do + response <- THW.request method "" [] "" + liftIO $ simpleHeaders response `shouldContain` + [("Content-Type", "application/json")] + + test "GET 200" get200 methodGet 200 + test "POST 210" post210 methodPost 210 + test "PUT 203" put203 methodPut 203 + test "DELETE 280" delete280 methodDelete 280 + test "PATCH 214" patch214 methodPatch 214 + test "GET 200 with HEAD" get200 methodHead 200 + +-- }}} +------------------------------------------------------------------------------ +-- * captureSpec {{{ +------------------------------------------------------------------------------ type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal captureApi :: Proxy CaptureApi @@ -118,8 +202,8 @@ captureSpec = do response <- get "/2" liftIO $ decode' (simpleBody response) `shouldBe` Just tweety - it "returns 404 if the decoding fails" $ do - get "/notAnInt" `shouldRespondWith` 404 + it "returns 400 if the decoding fails" $ do + get "/notAnInt" `shouldRespondWith` 400 with (return (serve (Proxy :: Proxy (Capture "captured" String :> Raw)) @@ -128,63 +212,10 @@ captureSpec = do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) - -type GetApi = Get '[JSON] Person - :<|> "empty" :> Get '[] () - :<|> "post" :> Post '[] () -getApi :: Proxy GetApi -getApi = Proxy - -getSpec :: Spec -getSpec = do - describe "Servant.API.Get" $ do - let server = return alice :<|> return () :<|> return () - with (return $ serve getApi server) $ do - - it "allows to GET a Person" $ do - response <- get "/" - return response `shouldRespondWith` 200 - liftIO $ decode' (simpleBody response) `shouldBe` Just alice - - it "throws 405 (wrong method) on POSTs" $ do - post "/" "" `shouldRespondWith` 405 - post "/empty" "" `shouldRespondWith` 405 - - it "returns 204 if the type is '()'" $ do - get "/empty" `shouldRespondWith` ""{ matchStatus = 204 } - - it "returns 406 if the Accept header is not supported" $ do - Test.Hspec.Wai.request methodGet "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 - - -headSpec :: Spec -headSpec = do - describe "Servant.API.Head" $ do - let server = return alice :<|> return () :<|> return () - with (return $ serve getApi server) $ do - - it "allows to GET a Person" $ do - response <- Test.Hspec.Wai.request methodHead "/" [] "" - return response `shouldRespondWith` 200 - liftIO $ decode' (simpleBody response) `shouldBe` (Nothing :: Maybe Person) - - it "does not allow HEAD to POST route" $ do - response <- Test.Hspec.Wai.request methodHead "/post" [] "" - return response `shouldRespondWith` 405 - - it "throws 405 (wrong method) on POSTs" $ do - post "/" "" `shouldRespondWith` 405 - post "/empty" "" `shouldRespondWith` 405 - - it "returns 204 if the type is '()'" $ do - response <- Test.Hspec.Wai.request methodHead "/empty" [] "" - return response `shouldRespondWith` ""{ matchStatus = 204 } - - it "returns 406 if the Accept header is not supported" $ do - Test.Hspec.Wai.request methodHead "" [(hAccept, "crazy/mime")] "" - `shouldRespondWith` 406 - +-- }}} +------------------------------------------------------------------------------ +-- * queryParamSpec {{{ +------------------------------------------------------------------------------ type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person :<|> "a" :> QueryParams "names" String :> Get '[JSON] Person @@ -208,7 +239,7 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize queryParamSpec :: Spec queryParamSpec = do describe "Servant.API.QueryParam" $ do - it "allows to retrieve simple GET parameters" $ + it "allows retrieving simple GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params1 = "?name=bob" response1 <- Network.Wai.Test.request defaultRequest{ @@ -220,7 +251,7 @@ queryParamSpec = do name = "bob" } - it "allows to retrieve lists in GET parameters" $ + it "allows retrieving lists in GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params2 = "?names[]=bob&names[]=john" response2 <- Network.Wai.Test.request defaultRequest{ @@ -234,7 +265,7 @@ queryParamSpec = do } - it "allows to retrieve value-less GET parameters" $ + it "allows retrieving value-less GET parameters" $ (flip runSession) (serve queryParamApi qpServer) $ do let params3 = "?capitalize" response3 <- Network.Wai.Test.request defaultRequest{ @@ -269,131 +300,41 @@ queryParamSpec = do name = "Alice" } -type PostApi = - ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer - :<|> "empty" :> Post '[] () +-- }}} +------------------------------------------------------------------------------ +-- * reqBodySpec {{{ +------------------------------------------------------------------------------ +type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person + :<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer -postApi :: Proxy PostApi -postApi = Proxy +reqBodyApi :: Proxy ReqBodyApi +reqBodyApi = Proxy -postSpec :: Spec -postSpec = do - describe "Servant.API.Post and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve postApi server) $ do - let post' x = Test.Hspec.Wai.request methodPost x [(hContentType - , "application/json;charset=utf-8")] +reqBodySpec :: Spec +reqBodySpec = describe "Servant.API.ReqBody" $ do - it "allows to POST a Person" $ do - post' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 - } + let server :: Server ReqBodyApi + server = return :<|> return . age + mkReq method x = THW.request method x + [(hContentType, "application/json;charset=utf-8")] - it "allows alternative routes if all have request bodies" $ do - post' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 - } + with (return $ serve reqBodyApi server) $ do - it "handles trailing '/' gracefully" $ do - post' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 201 - } + it "passes the argument to the handler" $ do + response <- mkReq methodPost "" (encode alice) + liftIO $ decode' (simpleBody response) `shouldBe` Just alice - it "correctly rejects invalid request bodies with status 400" $ do - post' "/" "some invalid body" `shouldRespondWith` 400 + it "rejects invalid request bodies with status 400" $ do + mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400 - it "returns 204 if the type is '()'" $ do - post' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } + it "responds with 415 if the request body media type is unsupported" $ do + THW.request methodPost "/" + [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415 - it "responds with 415 if the request body media type is unsupported" $ do - let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType - , "application/nonsense")] - post'' "/" "anything at all" `shouldRespondWith` 415 - -type PutApi = - ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Put '[JSON] Integer - :<|> "empty" :> Put '[] () - -putApi :: Proxy PutApi -putApi = Proxy - -putSpec :: Spec -putSpec = do - describe "Servant.API.Put and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve putApi server) $ do - let put' x = Test.Hspec.Wai.request methodPut x [(hContentType - , "application/json;charset=utf-8")] - - it "allows to put a Person" $ do - put' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "allows alternative routes if all have request bodies" $ do - put' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "handles trailing '/' gracefully" $ do - put' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "correctly rejects invalid request bodies with status 400" $ do - put' "/" "some invalid body" `shouldRespondWith` 400 - - it "returns 204 if the type is '()'" $ do - put' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - - it "responds with 415 if the request body media type is unsupported" $ do - let put'' x = Test.Hspec.Wai.request methodPut x [(hContentType - , "application/nonsense")] - put'' "/" "anything at all" `shouldRespondWith` 415 - -type PatchApi = - ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "bla" :> ReqBody '[JSON] Person :> Patch '[JSON] Integer - :<|> "empty" :> Patch '[] () - -patchApi :: Proxy PatchApi -patchApi = Proxy - -patchSpec :: Spec -patchSpec = do - describe "Servant.API.Patch and .ReqBody" $ do - let server = return . age :<|> return . age :<|> return () - with (return $ serve patchApi server) $ do - let patch' x = Test.Hspec.Wai.request methodPatch x [(hContentType - , "application/json;charset=utf-8")] - - it "allows to patch a Person" $ do - patch' "/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "allows alternative routes if all have request bodies" $ do - patch' "/bla" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "handles trailing '/' gracefully" $ do - patch' "/bla/" (encode alice) `shouldRespondWith` "42"{ - matchStatus = 200 - } - - it "correctly rejects invalid request bodies with status 400" $ do - patch' "/" "some invalid body" `shouldRespondWith` 400 - - it "returns 204 if the type is '()'" $ do - patch' "empty" "" `shouldRespondWith` ""{ matchStatus = 204 } - - it "responds with 415 if the request body media type is unsupported" $ do - let patch'' x = Test.Hspec.Wai.request methodPatch x [(hContentType - , "application/nonsense")] - patch'' "/" "anything at all" `shouldRespondWith` 415 +-- }}} +------------------------------------------------------------------------------ +-- * headerSpec {{{ +------------------------------------------------------------------------------ type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] () headerApi :: Proxy (HeaderApi a) @@ -411,23 +352,30 @@ headerSpec = describe "Servant.API.Header" $ do expectsString Nothing = error "Expected a string" with (return (serve headerApi expectsInt)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")] + let delete' x = THW.request methodDelete x [("MyHeader", "5")] it "passes the header to the handler (Int)" $ - delete' "/" "" `shouldRespondWith` 204 + delete' "/" "" `shouldRespondWith` 200 with (return (serve headerApi expectsString)) $ do - let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")] + let delete' x = THW.request methodDelete x [("MyHeader", "more from you")] it "passes the header to the handler (String)" $ - delete' "/" "" `shouldRespondWith` 204 + delete' "/" "" `shouldRespondWith` 200 +-- }}} +------------------------------------------------------------------------------ +-- * rawSpec {{{ +------------------------------------------------------------------------------ type RawApi = "foo" :> Raw + rawApi :: Proxy RawApi rawApi = Proxy + rawApplication :: Show a => (Request -> a) -> Application -rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_) +rawApplication f request_ respond = respond $ responseLBS ok200 [] + (cs $ show $ f request_) rawSpec :: Spec rawSpec = do @@ -448,7 +396,10 @@ rawSpec = do liftIO $ do simpleBody response `shouldBe` cs (show ["bar" :: String]) - +-- }}} +------------------------------------------------------------------------------ +-- * alternativeSpec {{{ +------------------------------------------------------------------------------ type AlternativeApi = "foo" :> Get '[JSON] Person :<|> "bar" :> Get '[JSON] Animal @@ -456,11 +407,12 @@ type AlternativeApi = :<|> "bar" :> Post '[JSON] Animal :<|> "bar" :> Put '[JSON] Animal :<|> "bar" :> Delete '[JSON] () -unionApi :: Proxy AlternativeApi -unionApi = Proxy -unionServer :: Server AlternativeApi -unionServer = +alternativeApi :: Proxy AlternativeApi +alternativeApi = Proxy + +alternativeServer :: Server AlternativeApi +alternativeServer = return alice :<|> return jerry :<|> return "a string" @@ -468,10 +420,10 @@ unionServer = :<|> return jerry :<|> return () -unionSpec :: Spec -unionSpec = do +alternativeSpec :: Spec +alternativeSpec = do describe "Servant.API.Alternative" $ do - with (return $ serve unionApi unionServer) $ do + with (return $ serve alternativeApi alternativeServer) $ do it "unions endpoints" $ do response <- get "/foo" @@ -488,7 +440,10 @@ unionSpec = do it "returns 404 if the path does not exist" $ do get "/nonexistent" `shouldRespondWith` 404 - +-- }}} +------------------------------------------------------------------------------ +-- * responseHeaderSpec {{{ +------------------------------------------------------------------------------ type ResponseHeadersApi = Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) :<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String) @@ -505,26 +460,29 @@ responseHeadersSpec :: Spec responseHeadersSpec = describe "ResponseHeaders" $ do with (return $ serve (Proxy :: Proxy ResponseHeadersApi) responseHeadersServer) $ do - let methods = [(methodGet, 200), (methodPost, 201), (methodPut, 200), (methodPatch, 200)] + let methods = [methodGet, methodPost, methodPut, methodPatch] it "includes the headers in the response" $ - forM_ methods $ \(method, expected) -> - Test.Hspec.Wai.request method "/" [] "" + forM_ methods $ \method -> + THW.request method "/" [] "" `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"] - , matchStatus = expected + , matchStatus = 200 } it "responds with not found for non-existent endpoints" $ - forM_ methods $ \(method,_) -> - Test.Hspec.Wai.request method "blahblah" [] "" + forM_ methods $ \method -> + THW.request method "blahblah" [] "" `shouldRespondWith` 404 it "returns 406 if the Accept header is not supported" $ - forM_ methods $ \(method,_) -> - Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] "" + forM_ methods $ \method -> + THW.request method "" [(hAccept, "crazy/mime")] "" `shouldRespondWith` 406 - +-- }}} +------------------------------------------------------------------------------ +-- * routerSpec {{{ +------------------------------------------------------------------------------ routerSpec :: Spec routerSpec = do describe "Servant.Server.Internal.Router" $ do @@ -543,6 +501,10 @@ routerSpec = do it "calls f on route result" $ do get "" `shouldRespondWith` 202 +-- }}} +------------------------------------------------------------------------------ +-- * miscCombinatorSpec {{{ +------------------------------------------------------------------------------ type MiscCombinatorsAPI = "version" :> HttpVersion :> Get '[JSON] String :<|> "secure" :> IsSecure :> Get '[JSON] String @@ -561,8 +523,8 @@ miscServ = versionHandler secureHandler NotSecure = return "not secure" hostHandler = return . show -miscReqCombinatorsSpec :: Spec -miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ +miscCombinatorSpec :: Spec +miscCombinatorSpec = with (return $ serve miscApi miscServ) $ describe "Misc. combinators for request inspection" $ do it "Successfully gets the HTTP version specified in the request" $ go "/version" "\"HTTP/1.0\"" @@ -574,3 +536,101 @@ miscReqCombinatorsSpec = with (return $ serve miscApi miscServ) $ go "/host" "\"0.0.0.0:0\"" where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res + +-- }}} +------------------------------------------------------------------------------ +-- * Basic Authentication {{{ +------------------------------------------------------------------------------ + +type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal + +basicAuthApi :: Proxy BasicAuthAPI +basicAuthApi = Proxy +basicAuthServer :: Server BasicAuthAPI +basicAuthServer = const (return jerry) + +basicAuthContext :: Context '[ BasicAuthCheck () ] +basicAuthContext = + let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) -> + if usr == "servant" && pass == "server" + then return (Authorized ()) + else return Unauthorized + ) + in basicHandler :. EmptyContext + +basicAuthSpec :: Spec +basicAuthSpec = do + describe "Servant.API.BasicAuth" $ do + with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ do + + context "Basic Authentication" $ do + it "returns with 401 with bad password" $ do + get "/basic" `shouldRespondWith` 401 + it "returns 200 with the right password" $ do + THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200 + +-- }}} +------------------------------------------------------------------------------ +-- * General Authentication {{{ +------------------------------------------------------------------------------ + +type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal +authApi :: Proxy GenAuthAPI +authApi = Proxy +authServer :: Server GenAuthAPI +authServer = const (return tweety) + +type instance AuthServerData (AuthProtect "auth") = () + +genAuthContext :: Context '[ AuthHandler Request () ] +genAuthContext = + let authHandler = (\req -> + if elem ("Auth", "secret") (requestHeaders req) + then return () + else throwE err401 + ) + in mkAuthHandler authHandler :. EmptyContext + +genAuthSpec :: Spec +genAuthSpec = do + describe "Servant.API.Auth" $ do + with (return (serveWithContext authApi genAuthContext authServer)) $ do + + context "Custom Auth Protection" $ do + it "returns 401 when missing headers" $ do + get "/auth" `shouldRespondWith` 401 + it "returns 200 with the right header" $ do + THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200 + +-- }}} +------------------------------------------------------------------------------ +-- * Test data types {{{ +------------------------------------------------------------------------------ + +data Person = Person { + name :: String, + age :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Person +instance FromJSON Person + +alice :: Person +alice = Person "Alice" 42 + +data Animal = Animal { + species :: String, + numberOfLegs :: Integer + } + deriving (Eq, Show, Generic) + +instance ToJSON Animal +instance FromJSON Animal + +jerry :: Animal +jerry = Animal "Mouse" 4 + +tweety :: Animal +tweety = Animal "Bird" 2 +-- }}} diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index 3630b313..94c63f18 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -15,12 +15,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) -import Servant.API (JSON) -import Servant.API.Alternative ((:<|>) ((:<|>))) -import Servant.API.Capture (Capture) -import Servant.API.Get (Get) -import Servant.API.Raw (Raw) -import Servant.API.Sub ((:>)) +import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) import Servant.Server (Server, serve) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) diff --git a/servant/.ghci b/servant/.ghci new file mode 100644 index 00000000..e5c6777e --- /dev/null +++ b/servant/.ghci @@ -0,0 +1 @@ +:set -isrc -itest -Iinclude -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index ddbe1a90..efeecf66 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,12 +1,17 @@ -HEAD +0.5 ---- +* Add `WithNamedConfig` combinator. * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Fix safeLink, so Header is not in fact required. * Add more instances for (:<|>) * Use `http-api-data` instead of `Servant.Common.Text` * Remove matrix params. * Add PlainText String MimeRender and MimeUnrender instances. +* Add new `Verbs` combinator, and make all existing and new verb combinators +type synonyms of it. +* Add `BasicAuth` combinator to support Basic authentication +* Add generalized authentication support 0.4.2 ----- diff --git a/servant/LICENSE b/servant/LICENSE index bfee8018..9717a9ce 100644 --- a/servant/LICENSE +++ b/servant/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Zalora South East Asia Pte Ltd +Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors All rights reserved. diff --git a/servant/include/overlapping-compat.h b/servant/include/overlapping-compat.h new file mode 100644 index 00000000..eef9d4ea --- /dev/null +++ b/servant/include/overlapping-compat.h @@ -0,0 +1,8 @@ +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPABLE_ +#define OVERLAPPING_ +#endif diff --git a/servant/servant.cabal b/servant/servant.cabal index f717eab3..51e1ce3b 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -1,5 +1,5 @@ name: servant -version: 0.5 +version: 0.6 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them @@ -11,11 +11,12 @@ homepage: http://haskell-servant.github.io/ Bug-reports: http://github.com/haskell-servant/servant/issues license: BSD3 license-file: LICENSE -author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni -maintainer: alpmestan@gmail.com -copyright: 2014 Zalora South East Asia Pte Ltd +author: Servant Contributors +maintainer: haskell-servant-maintainers@googlegroups.com +copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors category: Web build-type: Simple +extra-source-files: include/*.h cabal-version: >=1.10 tested-with: GHC >= 7.8 source-repository head @@ -26,16 +27,14 @@ library exposed-modules: Servant.API Servant.API.Alternative + Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes - Servant.API.Delete - Servant.API.Get + Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion + Servant.API.Internal.Test.ComprehensiveAPI Servant.API.IsSecure - Servant.API.Patch - Servant.API.Post - Servant.API.Put Servant.API.QueryParam Servant.API.Raw Servant.API.RemoteHost @@ -43,9 +42,12 @@ library Servant.API.ResponseHeaders Servant.API.Sub Servant.API.Vault + Servant.API.Verbs + Servant.API.WithNamedContext Servant.Utils.Links build-depends: - base >=4.7 && <5 + base >= 4.7 && < 4.9 + , base-compat >= 0.9 , aeson >= 0.7 , attoparsec >= 0.12 , bytestring == 0.10.* @@ -81,6 +83,7 @@ library , TypeSynonymInstances , UndecidableInstances ghc-options: -Wall + include-dirs: include test-suite spec type: exitcode-stdio-1.0 @@ -118,3 +121,4 @@ test-suite doctests buildable: True default-language: Haskell2010 ghc-options: -threaded + include-dirs: include diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2e6abb2a..5ea7b480 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -23,18 +23,14 @@ module Servant.API ( -- | Is the request made through HTTPS? module Servant.API.Vault, -- | Access the location for arbitrary data to be shared by applications and middleware + module Servant.API.WithNamedContext, + -- | Access context entries in combinators in servant-server -- * Actual endpoints, distinguished by HTTP method - module Servant.API.Get, - -- | @GET@ requests - module Servant.API.Post, - -- | @POST@ requests - module Servant.API.Delete, - -- | @DELETE@ requests - module Servant.API.Put, - -- | @PUT@ requests - module Servant.API.Patch, - -- | @PATCH@ requests + module Servant.API.Verbs, + + -- * Authentication + module Servant.API.BasicAuth, -- * Content Types module Servant.API.ContentTypes, @@ -52,26 +48,28 @@ module Servant.API ( module Web.HttpApiData, -- | Classes and instances for types that can be converted to and from HTTP API data. + + -- * Experimental modules + module Servant.API.Experimental.Auth, + -- | General Authentication + -- * Utilities module Servant.Utils.Links, -- | Type-safe internal URIs ) where import Servant.API.Alternative ((:<|>) (..)) +import Servant.API.BasicAuth (BasicAuth,BasicAuthData(..)) import Servant.API.Capture (Capture) import Servant.API.ContentTypes (Accept (..), FormUrlEncoded, FromFormUrlEncoded (..), JSON, - MimeRender (..), + MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText, ToFormUrlEncoded (..)) -import Servant.API.Delete (Delete) -import Servant.API.Get (Get) +import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) -import Servant.API.Patch (Patch) -import Servant.API.Post (Post) -import Servant.API.Put (Put) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) import Servant.API.Raw (Raw) @@ -84,7 +82,26 @@ import Servant.API.ResponseHeaders (AddHeader (addHeader), getHeadersHList, getResponse) import Servant.API.Sub ((:>)) import Servant.API.Vault (Vault) -import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) +import Servant.API.Verbs (PostCreated, Delete, DeleteAccepted, + DeleteNoContent, + DeleteNonAuthoritative, Get, + GetAccepted, GetNoContent, + GetNonAuthoritative, + GetPartialContent, + GetResetContent, + Patch, + PatchAccepted, PatchNoContent, + PatchNoContent, + PatchNonAuthoritative, Post, + PostAccepted, PostNoContent, + PostNonAuthoritative, + PostResetContent, Put, + PutAccepted, PutNoContent, + PutNoContent, PutNonAuthoritative, + ReflectMethod (reflectMethod), + Verb, StdMethod(..)) +import Servant.API.WithNamedContext (WithNamedContext) import Servant.Utils.Links (HasLink (..), IsElem, IsElem', URI (..), safeLink) - +import Web.HttpApiData (FromHttpApiData (..), + ToHttpApiData (..)) diff --git a/servant/src/Servant/API/Alternative.hs b/servant/src/Servant/API/Alternative.hs index 752dcef0..a7651d3c 100644 --- a/servant/src/Servant/API/Alternative.hs +++ b/servant/src/Servant/API/Alternative.hs @@ -9,12 +9,10 @@ {-# OPTIONS_HADDOCK not-home #-} module Servant.API.Alternative ((:<|>)(..)) where -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid (Monoid (..)) -import Data.Traversable (Traversable) -import Data.Foldable (Foldable) -#endif import Data.Typeable (Typeable) +import Prelude () +import Prelude.Compat + -- | Union of two APIs, first takes precedence in case of overlap. -- -- Example: diff --git a/servant/src/Servant/API/BasicAuth.hs b/servant/src/Servant/API/BasicAuth.hs new file mode 100644 index 00000000..cc38ddb3 --- /dev/null +++ b/servant/src/Servant/API/BasicAuth.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.BasicAuth where + +import Data.ByteString (ByteString) +import Data.Typeable (Typeable) +import GHC.TypeLits (Symbol) + + +-- | Combinator for . +-- +-- *IMPORTANT*: Only use Basic Auth over HTTPS! Credentials are not hashed or +-- encrypted. Note also that because the same credentials are sent on every +-- request, Basic Auth is not as secure as some alternatives. Further, the +-- implementation in servant-server does not protect against some types of +-- timing attacks. +-- +-- In Basic Auth, username and password are base64-encoded and transmitted via +-- the @Authorization@ header. Handshakes are not required, making it +-- relatively efficient. +data BasicAuth (realm :: Symbol) (userData :: *) + deriving (Typeable) + +-- | A simple datatype to hold data required to decorate a request +data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString + , basicAuthPassword :: !ByteString + } diff --git a/servant/src/Servant/API/ContentTypes.hs b/servant/src/Servant/API/ContentTypes.hs index ab857ce2..6ca29330 100644 --- a/servant/src/Servant/API/ContentTypes.hs +++ b/servant/src/Servant/API/ContentTypes.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -12,6 +13,8 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" + -- | A collection of basic Content-Types (also known as Internet Media -- Types, or MIME types). Additionally, this module provides classes that -- encapsulate how to serialize or deserialize values to or from @@ -19,7 +22,7 @@ -- -- Content-Types are used in `ReqBody` and the method combinators: -- --- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] :> Book +-- >>> type MyEndpoint = ReqBody '[JSON, PlainText] Book :> Get '[JSON, PlainText] Book -- -- Meaning the endpoint accepts requests of Content-Type @application/json@ -- or @text/plain;charset-utf8@, and returns data in either one of those @@ -53,6 +56,9 @@ module Servant.API.ContentTypes , MimeRender(..) , MimeUnrender(..) + -- * NoContent + , NoContent(..) + -- * Internal , AcceptHeader(..) , AllCTRender(..) @@ -62,18 +68,13 @@ module Servant.API.ContentTypes , AllMimeUnrender(..) , FromFormUrlEncoded(..) , ToFormUrlEncoded(..) - , IsNonEmpty , eitherDecodeLenient , canHandleAcceptH ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((*>), (<*)) -#endif import Control.Arrow (left) -import Control.Monad -import Data.Aeson (FromJSON, ToJSON, encode, - parseJSON) +import Control.Monad.Compat +import Data.Aeson (FromJSON(..), ToJSON(..), encode) import Data.Aeson.Parser (value) import Data.Aeson.Types (parseEither) import Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly, @@ -84,17 +85,19 @@ import Data.ByteString.Lazy (ByteString, fromStrict, import qualified Data.ByteString.Lazy as B import qualified Data.ByteString.Lazy.Char8 as BC import Data.Maybe (isJust) -import Data.Monoid +import Data.Monoid.Compat import Data.String.Conversions (cs) import qualified Data.Text as TextS import qualified Data.Text.Encoding as TextS import qualified Data.Text.Lazy as TextL import qualified Data.Text.Lazy.Encoding as TextL import Data.Typeable -import GHC.Exts (Constraint) +import GHC.Generics (Generic) import qualified Network.HTTP.Media as M import Network.URI (escapeURIString, isUnreserved, unEscapeString) +import Prelude () +import Prelude.Compat -- * Provided content types data JSON deriving Typeable @@ -137,7 +140,7 @@ instance Accept OctetStream where contentType _ = "application" M.// "octet-stream" newtype AcceptHeader = AcceptHeader BS.ByteString - deriving (Eq, Show) + deriving (Eq, Show, Read, Typeable, Generic) -- * Render (serializing) @@ -159,19 +162,19 @@ newtype AcceptHeader = AcceptHeader BS.ByteString class Accept ctype => MimeRender ctype a where mimeRender :: Proxy ctype -> a -> ByteString -class (AllMimeRender list a) => AllCTRender (list :: [*]) a where +class (AllMime list) => AllCTRender (list :: [*]) a where -- If the Accept header can be matched, returns (Just) a tuple of the -- Content-Type and response (serialization of @a@ into the appropriate -- mimetype). handleAcceptH :: Proxy list -> AcceptHeader -> a -> Maybe (ByteString, ByteString) -instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where +instance OVERLAPPABLE_ + (AllMimeRender (ct ': cts) a) => AllCTRender (ct ': cts) a where handleAcceptH _ (AcceptHeader accept) val = M.mapAcceptMedia lkup accept - where pctyps = Proxy :: Proxy ctyps + where pctyps = Proxy :: Proxy (ct ': cts) amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs - -------------------------------------------------------------------------- -- * Unrender @@ -199,14 +202,13 @@ instance (AllMimeRender ctyps a, IsNonEmpty ctyps) => AllCTRender ctyps a where class Accept ctype => MimeUnrender ctype a where mimeUnrender :: Proxy ctype -> ByteString -> Either String a -class (IsNonEmpty list) => AllCTUnrender (list :: [*]) a where +class AllCTUnrender (list :: [*]) a where handleCTypeH :: Proxy list -> ByteString -- Content-Type header -> ByteString -- Request body -> Maybe (Either String a) -instance ( AllMimeUnrender ctyps a, IsNonEmpty ctyps - ) => AllCTUnrender ctyps a where +instance ( AllMimeUnrender ctyps a ) => AllCTUnrender ctyps a where handleCTypeH _ ctypeH body = M.mapContentMedia lkup (cs ctypeH) where lkup = allMimeUnrender (Proxy :: Proxy ctyps) body @@ -235,11 +237,12 @@ class (AllMime list) => AllMimeRender (list :: [*]) a where -> a -- value to serialize -> [(M.MediaType, ByteString)] -- content-types/response pairs -instance ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where +instance OVERLAPPABLE_ ( MimeRender ctyp a ) => AllMimeRender '[ctyp] a where allMimeRender _ a = [(contentType pctyp, mimeRender pctyp a)] where pctyp = Proxy :: Proxy ctyp -instance ( MimeRender ctyp a +instance OVERLAPPABLE_ + ( MimeRender ctyp a , AllMimeRender (ctyp' ': ctyps) a ) => AllMimeRender (ctyp ': ctyp' ': ctyps) a where allMimeRender _ a = (contentType pctyp, mimeRender pctyp a) @@ -248,8 +251,17 @@ instance ( MimeRender ctyp a pctyps = Proxy :: Proxy (ctyp' ': ctyps) -instance AllMimeRender '[] a where - allMimeRender _ _ = [] +-- Ideally we would like to declare a 'MimeRender a NoContent' instance, and +-- then this would be taken care of. However there is no more specific instance +-- between that and 'MimeRender JSON a', so we do this instead +instance OVERLAPPING_ ( Accept ctyp ) => AllMimeRender '[ctyp] NoContent where + allMimeRender _ _ = [(contentType pctyp, "")] + where pctyp = Proxy :: Proxy ctyp + +instance OVERLAPPING_ + ( AllMime (ctyp ': ctyp' ': ctyps) + ) => AllMimeRender (ctyp ': ctyp' ': ctyps) NoContent where + allMimeRender p _ = zip (allMime p) (repeat "") -------------------------------------------------------------------------- -- Check that all elements of list are instances of MimeUnrender @@ -270,21 +282,19 @@ instance ( MimeUnrender ctyp a where pctyp = Proxy :: Proxy ctyp pctyps = Proxy :: Proxy ctyps -type family IsNonEmpty (list :: [*]) :: Constraint where - IsNonEmpty (x ': xs) = () - - -------------------------------------------------------------------------- -- * MimeRender Instances -- | `encode` -instance ToJSON a => MimeRender JSON a where +instance OVERLAPPABLE_ + ToJSON a => MimeRender JSON a where mimeRender _ = encode -- | @encodeFormUrlEncoded . toFormUrlEncoded@ -- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only -- holds if every element of x is non-null (i.e., not @("", "")@) -instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where +instance OVERLAPPABLE_ + ToFormUrlEncoded a => MimeRender FormUrlEncoded a where mimeRender _ = encodeFormUrlEncoded . toFormUrlEncoded -- | `TextL.encodeUtf8` @@ -307,6 +317,10 @@ instance MimeRender OctetStream ByteString where instance MimeRender OctetStream BS.ByteString where mimeRender _ = fromStrict +-- | A type for responses without content-body. +data NoContent = NoContent + deriving (Show, Eq, Read) + -------------------------------------------------------------------------- -- * MimeUnrender Instances diff --git a/servant/src/Servant/API/Delete.hs b/servant/src/Servant/API/Delete.hs deleted file mode 100644 index de792a28..00000000 --- a/servant/src/Servant/API/Delete.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Delete (Delete) where - -import Data.Typeable (Typeable) - --- | Combinator for DELETE requests. --- --- Example: --- --- >>> -- DELETE /books/:isbn --- >>> type MyApi = "books" :> Capture "isbn" Text :> Delete '[] () -data Delete (contentTypes :: [*]) a - deriving Typeable - - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Experimental/Auth.hs b/servant/src/Servant/API/Experimental/Auth.hs new file mode 100644 index 00000000..ce330287 --- /dev/null +++ b/servant/src/Servant/API/Experimental/Auth.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.Experimental.Auth where + +import Data.Typeable (Typeable) + +-- | A generalized Authentication combinator. Use this if you have a +-- non-standard authentication technique. +-- +-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE. +data AuthProtect (tag :: k) deriving (Typeable) + diff --git a/servant/src/Servant/API/Get.hs b/servant/src/Servant/API/Get.hs deleted file mode 100644 index 073bfda6..00000000 --- a/servant/src/Servant/API/Get.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Get (Get) where - -import Data.Typeable (Typeable) - --- | Endpoint for simple GET requests. Serves the result as JSON. --- --- Example: --- --- >>> type MyApi = "books" :> Get '[JSON] [Book] -data Get (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs new file mode 100644 index 00000000..91d01727 --- /dev/null +++ b/servant/src/Servant/API/Internal/Test/ComprehensiveAPI.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +-- | This is a module containing an API with all `Servant.API` combinators. It +-- is used for testing only (in particular, checking that instances exist for +-- the core servant classes for each combinator), and should not be imported. +module Servant.API.Internal.Test.ComprehensiveAPI where + +import Data.Proxy + +import Servant.API + +type GET = Get '[JSON] () + +type ComprehensiveAPI = + GET :<|> + Get '[JSON] Int :<|> + Capture "foo" Int :> GET :<|> + Header "foo" Int :> GET :<|> + HttpVersion :> GET :<|> + IsSecure :> GET :<|> + QueryParam "foo" Int :> GET :<|> + QueryParams "foo" Int :> GET :<|> + QueryFlag "foo" :> GET :<|> +-- Raw :<|> + RemoteHost :> GET :<|> + ReqBody '[JSON] Int :> GET :<|> + Get '[JSON] (Headers '[Header "foo" Int] ()) :<|> + "foo" :> GET :<|> + Vault :> GET :<|> + Verb 'POST 204 '[JSON] () :<|> + Verb 'POST 204 '[JSON] Int :<|> + WithNamedContext "foo" '[] GET + +comprehensiveAPI :: Proxy ComprehensiveAPI +comprehensiveAPI = Proxy diff --git a/servant/src/Servant/API/Patch.hs b/servant/src/Servant/API/Patch.hs deleted file mode 100644 index 715cf905..00000000 --- a/servant/src/Servant/API/Patch.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Patch (Patch) where - -import Data.Typeable (Typeable) - --- | Endpoint for PATCH requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- If the HTTP response is empty, only () is supported. --- --- Example: --- --- >>> -- PATCH /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Patch '[JSON] Book -data Patch (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Post.hs b/servant/src/Servant/API/Post.hs deleted file mode 100644 index 72bc59cc..00000000 --- a/servant/src/Servant/API/Post.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Post (Post) where - -import Data.Typeable (Typeable) - --- | Endpoint for POST requests. The type variable represents the type of the --- response body (not the request body, use 'Servant.API.ReqBody.ReqBody' for --- that). --- --- Example: --- --- >>> -- POST /books --- >>> -- with a JSON encoded Book as the request body --- >>> -- returning the just-created Book --- >>> type MyApi = "books" :> ReqBody '[JSON] Book :> Post '[JSON] Book -data Post (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Put.hs b/servant/src/Servant/API/Put.hs deleted file mode 100644 index 0b09d961..00000000 --- a/servant/src/Servant/API/Put.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} -module Servant.API.Put (Put) where - -import Data.Typeable (Typeable) - --- | Endpoint for PUT requests, usually used to update a ressource. --- The type @a@ is the type of the response body that's returned. --- --- Example: --- --- >>> -- PUT /books/:isbn --- >>> -- with a Book as request body, returning the updated Book --- >>> type MyApi = "books" :> Capture "isbn" Text :> ReqBody '[JSON] Book :> Put '[JSON] Book -data Put (contentTypes :: [*]) a - deriving Typeable - --- $setup --- >>> import Servant.API --- >>> import Data.Aeson --- >>> import Data.Text --- >>> data Book --- >>> instance ToJSON Book where { toJSON = undefined } diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index 90a5f4bd..41077711 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -9,6 +9,6 @@ import Data.Typeable (Typeable) -- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's, --- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve +-- this can also be used with to serve -- static files stored in a particular directory on your filesystem data Raw deriving Typeable diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index 1fcbd035..cde14938 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -12,11 +12,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#if !MIN_VERSION_base(4,8,0) -{-# LANGUAGE OverlappingInstances #-} -#endif {-# OPTIONS_HADDOCK not-home #-} +#include "overlapping-compat.h" -- | This module provides facilities for adding headers to a response. -- -- >>> let headerVal = addHeader "some-url" 5 :: Headers '[Header "Location" String] Int @@ -32,9 +30,6 @@ module Servant.API.ResponseHeaders , HList(..) ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif import Data.ByteString.Char8 as BS (pack, unlines, init) import Data.ByteString.Conversion (ToByteString, toByteString', FromByteString, fromByteString) @@ -44,6 +39,8 @@ import GHC.TypeLits (KnownSymbol, symbolVal) import qualified Network.HTTP.Types.Header as HTTP import Servant.API.Header (Header (..)) +import Prelude () +import Prelude.Compat -- | Response Header objects. You should never need to construct one directly. -- Instead, use 'addHeader'. @@ -68,19 +65,12 @@ class BuildHeadersTo hs where -- the values are interspersed with commas before deserialization (see -- ) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - BuildHeadersTo '[] where +instance OVERLAPPING_ BuildHeadersTo '[] where buildHeadersTo _ = HNil -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( FromByteString v, BuildHeadersTo xs, KnownSymbol h, Contains h xs ~ 'False - ) => BuildHeadersTo ((Header h v) ': xs) where +instance OVERLAPPABLE_ ( FromByteString v, BuildHeadersTo xs, KnownSymbol h + , Contains h xs ~ 'False) + => BuildHeadersTo ((Header h v) ': xs) where buildHeadersTo headers = let wantedHeader = CI.mk . pack $ symbolVal (Proxy :: Proxy h) matching = snd <$> filter (\(h, _) -> h == wantedHeader) headers @@ -96,38 +86,22 @@ instance class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (HList '[]) where +instance OVERLAPPING_ GetHeaders (HList '[]) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString x, GetHeaders (HList xs) - ) => GetHeaders (HList (Header h x ': xs)) where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString x, GetHeaders (HList xs)) + => GetHeaders (HList (Header h x ': xs)) where getHeaders hdrs = case hdrs of Header val `HCons` rest -> (headerName , toByteString' val):getHeaders rest UndecodableHeader h `HCons` rest -> (headerName, h) : getHeaders rest MissingHeader `HCons` rest -> getHeaders rest where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - GetHeaders (Headers '[] a) where +instance OVERLAPPING_ GetHeaders (Headers '[] a) where getHeaders _ = [] -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, GetHeaders (HList rest), ToByteString v - ) => GetHeaders (Headers (Header h v ': rest) a) where +instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToByteString v) + => GetHeaders (Headers (Header h v ': rest) a) where getHeaders hs = getHeaders $ getHeadersHList hs -- * Adding @@ -138,21 +112,13 @@ class AddHeader h v orig new addHeader :: v -> orig -> new -- ^ N.B.: The same header can't be added multiple times -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPING #-} -#endif - ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False - ) => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where +instance OVERLAPPING_ ( KnownSymbol h, ToByteString v, Contains h (fst ': rest) ~ 'False) + => AddHeader h v (Headers (fst ': rest) a) (Headers (Header h v ': fst ': rest) a) where addHeader a (Headers resp heads) = Headers resp (HCons (Header a) heads) -instance -#if MIN_VERSION_base(4,8,0) - {-# OVERLAPPABLE #-} -#endif - ( KnownSymbol h, ToByteString v - , new ~ (Headers '[Header h v] a) - ) => AddHeader h v a new where +instance OVERLAPPABLE_ ( KnownSymbol h, ToByteString v + , new ~ (Headers '[Header h v] a)) + => AddHeader h v a new where addHeader a resp = Headers resp (HCons (Header a) HNil) type family Contains x xs where diff --git a/servant/src/Servant/API/Verbs.hs b/servant/src/Servant/API/Verbs.hs new file mode 100644 index 00000000..1369d9f3 --- /dev/null +++ b/servant/src/Servant/API/Verbs.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +module Servant.API.Verbs + ( module Servant.API.Verbs + , StdMethod(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS, PATCH) + ) where + +import Data.Typeable (Typeable) +import Data.Proxy (Proxy) +import GHC.Generics (Generic) +import GHC.TypeLits (Nat) +import Network.HTTP.Types.Method (Method, StdMethod (..), + methodDelete, methodGet, methodHead, + methodPatch, methodPost, methodPut) + +-- | @Verb@ is a general type for representing HTTP verbs (a.k.a. methods). For +-- convenience, type synonyms for each verb with a 200 response code are +-- provided, but you are free to define your own: +-- +-- >>> type Post204 contentTypes a = Verb 'POST 204 contentTypes a +data Verb (method :: k1) (statusCode :: Nat) (contentTypes :: [*]) a + deriving (Typeable, Generic) + +-- * 200 responses +-- +-- The 200 response is the workhorse of web servers, but also fairly generic. +-- When appropriate, you should prefer the more specific success combinators. +-- More information about the definitions of status codes can be found in +-- and +-- ; +-- the relevant information is summarily presented here. + +-- | 'GET' with 200 status code. +type Get = Verb 'GET 200 +-- | 'POST' with 200 status code. +type Post = Verb 'POST 200 +-- | 'PUT' with 200 status code. +type Put = Verb 'PUT 200 +-- | 'DELETE' with 200 status code. +type Delete = Verb 'DELETE 200 +-- | 'PATCH' with 200 status code. +type Patch = Verb 'PATCH 200 + +-- * Other responses + +-- ** 201 Created +-- +-- Indicates that a new resource has been created. The URI corresponding to the +-- resource should be given in the @Location@ header field. +-- +-- If the resource cannot be created immediately, use 'PostAccepted'. +-- +-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header +-- field. + +-- | 'POST' with 201 status code. +-- +type PostCreated = Verb 'POST 201 + + +-- ** 202 Accepted +-- +-- Indicates that the request has been accepted for processing, but the +-- processing has not yet completed. The status of the processing should be +-- included, as well as either a link to a status monitoring endpoint or an +-- estimate of when the processing will be finished. + +-- | 'GET' with 202 status code. +type GetAccepted = Verb 'GET 202 +-- | 'POST' with 202 status code. +type PostAccepted = Verb 'POST 202 +-- | 'DELETE' with 202 status code. +type DeleteAccepted = Verb 'DELETE 202 +-- | 'PATCH' with 202 status code. +type PatchAccepted = Verb 'PATCH 202 +-- | 'PUT' with 202 status code. +type PutAccepted = Verb 'PUT 202 + + +-- ** 203 Non-Authoritative Information +-- +-- Indicates that the request has been successfully processed, but the +-- information may come from a third-party. + +-- | 'GET' with 203 status code. +type GetNonAuthoritative = Verb 'GET 203 +-- | 'POST' with 203 status code. +type PostNonAuthoritative = Verb 'POST 203 +-- | 'DELETE' with 203 status code. +type DeleteNonAuthoritative = Verb 'DELETE 203 +-- | 'PATCH' with 203 status code. +type PatchNonAuthoritative = Verb 'PATCH 203 +-- | 'PUT' with 203 status code. +type PutNonAuthoritative = Verb 'PUT 203 + + +-- ** 204 No Content +-- +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with headers. +-- +-- If the document view should be reset, use @205 Reset Content@. + +-- | 'GET' with 204 status code. +type GetNoContent = Verb 'GET 204 +-- | 'POST' with 204 status code. +type PostNoContent = Verb 'POST 204 +-- | 'DELETE' with 204 status code. +type DeleteNoContent = Verb 'DELETE 204 +-- | 'PATCH' with 204 status code. +type PatchNoContent = Verb 'PATCH 204 +-- | 'PUT' with 204 status code. +type PutNoContent = Verb 'PUT 204 + + +-- ** 205 Reset Content +-- +-- Indicates that no response body is being returned. Handlers for these should +-- return 'NoContent', possibly with Headers. +-- +-- If the document view should not be reset, use @204 No Content@. + +-- | 'GET' with 205 status code. +type GetResetContent = Verb 'GET 205 +-- | 'POST' with 205 status code. +type PostResetContent = Verb 'POST 205 +-- | 'DELETE' with 205 status code. +type DeleteResetContent = Verb 'DELETE 205 +-- | 'PATCH' with 205 status code. +type PatchResetContent = Verb 'PATCH 205 +-- | 'PUT' with 205 status code. +type PutResetContent = Verb 'PUT 205 + + +-- ** 206 Partial Content +-- +-- Indicates that the server is delivering part of the resource due to a range +-- header in the request. +-- +-- For more information, see + +-- | 'GET' with 206 status code. +type GetPartialContent = Verb 'GET 206 + + +class ReflectMethod a where + reflectMethod :: Proxy a -> Method + +instance ReflectMethod 'GET where + reflectMethod _ = methodGet + +instance ReflectMethod 'POST where + reflectMethod _ = methodPost + +instance ReflectMethod 'PUT where + reflectMethod _ = methodPut + +instance ReflectMethod 'DELETE where + reflectMethod _ = methodDelete + +instance ReflectMethod 'PATCH where + reflectMethod _ = methodPatch + +instance ReflectMethod 'HEAD where + reflectMethod _ = methodHead diff --git a/servant/src/Servant/API/WithNamedContext.hs b/servant/src/Servant/API/WithNamedContext.hs new file mode 100644 index 00000000..e467ea41 --- /dev/null +++ b/servant/src/Servant/API/WithNamedContext.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Servant.API.WithNamedContext where + +import GHC.TypeLits + +-- | 'WithNamedContext' names a specific tagged context to use for the +-- combinators in the API. (See also in @servant-server@, +-- @Servant.Server.Context@.) For example: +-- +-- > type UseNamedContextAPI = WithNamedContext "myContext" '[String] ( +-- > ReqBody '[JSON] Int :> Get '[JSON] Int) +-- +-- Both the 'ReqBody' and 'Get' combinators will use the 'WithNamedContext' with +-- type tag "myContext" as their context. +-- +-- 'Context's are only relevant for @servant-server@. +-- +-- For more information, see the tutorial. +data WithNamedContext (name :: Symbol) (subContext :: [*]) subApi diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index f218377f..2fb7d0a5 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} @@ -74,7 +73,7 @@ -- >>> safeLink api bad_link -- ... -- Could not deduce (Or --- (IsElem' (Delete '[JSON] ()) (Get '[JSON] Int)) +-- (IsElem' (Verb 'DELETE 200 '[JSON] ()) (Verb 'GET 200 '[JSON] Int)) -- (IsElem' -- ("hello" :> Delete '[JSON] ()) -- ("bye" :> (QueryParam "name" String :> Delete '[JSON] ())))) @@ -101,29 +100,23 @@ module Servant.Utils.Links ( , Or ) where -import Data.List -import Data.Proxy ( Proxy(..) ) -import qualified Data.Text as Text import qualified Data.ByteString.Char8 as BSC -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid ( Monoid(..), (<>) ) -#else -import Data.Monoid ( (<>) ) -#endif -import Network.URI ( URI(..), escapeURIString, isUnreserved ) -import GHC.TypeLits ( KnownSymbol, symbolVal ) -import GHC.Exts(Constraint) +import Data.List +import Data.Monoid.Compat ( (<>) ) +import Data.Proxy ( Proxy(..) ) +import qualified Data.Text as Text +import GHC.Exts (Constraint) +import GHC.TypeLits ( KnownSymbol, symbolVal ) +import Network.URI ( URI(..), escapeURIString, isUnreserved ) +import Prelude () +import Prelude.Compat import Web.HttpApiData import Servant.API.Capture ( Capture ) import Servant.API.ReqBody ( ReqBody ) import Servant.API.QueryParam ( QueryParam, QueryParams, QueryFlag ) import Servant.API.Header ( Header ) -import Servant.API.Get ( Get ) -import Servant.API.Post ( Post ) -import Servant.API.Put ( Put ) -import Servant.API.Patch ( Patch ) -import Servant.API.Delete ( Delete ) +import Servant.API.Verbs ( Verb ) import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.Alternative ( type (:<|>) ) @@ -177,11 +170,8 @@ type family IsElem endpoint api :: Constraint where IsElem sa (QueryParam x y :> sb) = IsElem sa sb IsElem sa (QueryParams x y :> sb) = IsElem sa sb IsElem sa (QueryFlag x :> sb) = IsElem sa sb - IsElem (Get ct typ) (Get ct' typ) = IsSubList ct ct' - IsElem (Post ct typ) (Post ct' typ) = IsSubList ct ct' - IsElem (Put ct typ) (Put ct' typ) = IsSubList ct ct' - IsElem (Patch ct typ) (Patch ct' typ) = IsSubList ct ct' - IsElem (Delete ct typ) (Delete ct' typ) = IsSubList ct ct' + IsElem (Verb m s ct typ) (Verb m s ct' typ) + = IsSubList ct ct' IsElem e e = () IsElem e a = IsElem' e a @@ -303,24 +293,8 @@ instance HasLink sub => HasLink (Header sym a :> sub) where toLink _ = toLink (Proxy :: Proxy sub) -- Verb (terminal) instances -instance HasLink (Get y r) where - type MkLink (Get y r) = URI - toLink _ = linkURI - -instance HasLink (Post y r) where - type MkLink (Post y r) = URI - toLink _ = linkURI - -instance HasLink (Put y r) where - type MkLink (Put y r) = URI - toLink _ = linkURI - -instance HasLink (Patch y r) where - type MkLink (Patch y r) = URI - toLink _ = linkURI - -instance HasLink (Delete y r) where - type MkLink (Delete y r) = URI +instance HasLink (Verb m s ct a) where + type MkLink (Verb m s ct a) = URI toLink _ = linkURI instance HasLink Raw where diff --git a/servant/test/Doctests.hs b/servant/test/Doctests.hs index bf6bcd23..d9116823 100644 --- a/servant/test/Doctests.hs +++ b/servant/test/Doctests.hs @@ -11,7 +11,7 @@ main = do files <- find always (extension ==? ".hs") "src" tfiles <- find always (extension ==? ".hs") "test/Servant" mCabalMacrosFile <- getCabalMacrosFile - doctest $ "-isrc" : + doctest $ "-isrc" : "-Iinclude" : (maybe [] (\ f -> ["-optP-include", "-optP" ++ f]) mCabalMacrosFile) ++ "-XOverloadedStrings" : "-XFlexibleInstances" : diff --git a/sources.txt b/sources.txt index 24719355..2d3f8107 100644 --- a/sources.txt +++ b/sources.txt @@ -5,7 +5,6 @@ servant-docs servant-foreign servant-js servant-server -servant-examples servant-blaze servant-lucid servant-mock diff --git a/stack-ghc-7.8.4.yaml b/stack-ghc-7.8.4.yaml index 9632e808..679b2b52 100644 --- a/stack-ghc-7.8.4.yaml +++ b/stack-ghc-7.8.4.yaml @@ -1,16 +1,18 @@ flags: {} packages: -- servant-examples/ -- servant-docs/ +- servant/ - servant-blaze/ +- servant-cassava/ - servant-client/ -- servant-lucid/ -- servant-mock/ +- servant-docs/ +- servant-examples/ - servant-foreign/ - servant-js/ -- servant/ +- servant-lucid/ +- servant-mock/ - servant-server/ extra-deps: +- base-compat-0.9.0 - hspec-2.2.0 - hspec-core-2.2.0 - hspec-discover-2.2.0 @@ -22,4 +24,5 @@ extra-deps: - stm-delay-0.1.1.1 - control-monad-omega-0.3.1 - http-api-data-0.1.1.1 +- should-not-typecheck-2.0.1 resolver: lts-2.22 diff --git a/stack.yaml b/stack.yaml index f370da09..947970a5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,13 +7,18 @@ packages: - servant-cassava/ - servant-client/ - servant-docs/ -- servant-examples/ - servant-foreign/ - servant-js/ - servant-lucid/ - servant-mock/ - servant-server/ +- doc/tutorial extra-deps: +- base-compat-0.9.0 - engine-io-wai-1.0.2 - control-monad-omega-0.3.1 -resolver: nightly-2015-10-08 +- should-not-typecheck-2.0.1 +- markdown-unlit-0.4.0 +- aeson-0.11.0.0 +- fail-4.9.0.0 +resolver: nightly-2016-03-17 diff --git a/travis.sh b/travis.sh new file mode 100755 index 00000000..60734911 --- /dev/null +++ b/travis.sh @@ -0,0 +1,13 @@ +#!/usr/bin/env bash + +set -o errexit + +for package in $(cat sources.txt) doc/tutorial ; do + echo testing $package + pushd $package + tinc + cabal configure --enable-tests --disable-optimization + cabal build + cabal test + popd +done