eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into client-ghcjs-wip

Browse source
This commit is contained in:
Sönke Hahn 2016-04-05 20:19:21 +08:00
commit 6a586858ae
160 changed files with 6754 additions and 3766 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.ghci
View file

@ -1 +0,0 @@
:set -itest -isrc -packagehspec2

4
.gitignore vendored
View file

@ -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

2
.travis.yml
View file

@ -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

86
CONTRIBUTING.md Normal file
View file

@ -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.

27
README.md
View file

@ -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`

216
doc/Makefile Normal file
View file

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

8
doc/building-the-docs Normal file
View file

@ -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 .

294
doc/conf.py Normal file
View file

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

22
doc/index.rst Normal file
View file

@ -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

40
doc/introduction.rst Normal file
View file

@ -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*.

34
doc/links.rst Normal file
View file

@ -0,0 +1,34 @@
Helpful Links
-------------
- the central documentation (this site):
`haskell-servant.readthedocs.org <http://haskell-servant.readthedocs.org/>`_
- the github repo:
`github.com/haskell-servant/servant <https://github.com/haskell-servant/servant>`_
- the issue tracker (Feel free to create issues and submit PRs!):
`https://github.com/haskell-servant/servant/issues <https://github.com/haskell-servant/servant/issues>`_
- the irc channel:
``#servant`` on freenode
- the mailing list:
`groups.google.com/forum/#!forum/haskell-servant <https://groups.google.com/forum/#!forum/haskell-servant>`_
- blog posts and videos and slides of some talks on servant:
`haskell-servant.github.io <http://haskell-servant.github.io>`_
- the servant packages on hackage:
- `hackage.haskell.org/package/servant <http://hackage.haskell.org/package/servant>`_
- `hackage.haskell.org/package/servant-server <http://hackage.haskell.org/package/servant-server>`_
- `hackage.haskell.org/package/servant-client <http://hackage.haskell.org/package/servant-client>`_
- `hackage.haskell.org/package/servant-blaze <http://hackage.haskell.org/package/servant-blaze>`_
- `hackage.haskell.org/package/servant-lucid <http://hackage.haskell.org/package/servant-lucid>`_
- `hackage.haskell.org/package/servant-cassava <http://hackage.haskell.org/package/servant-cassava>`_
- `hackage.haskell.org/package/servant-docs <http://hackage.haskell.org/package/servant-docs>`_
- `hackage.haskell.org/package/servant-foreign <http://hackage.haskell.org/package/servant-foreign>`_
- `hackage.haskell.org/package/servant-js <http://hackage.haskell.org/package/servant-js>`_
- `hackage.haskell.org/package/servant-mock <http://hackage.haskell.org/package/servant-mock>`_

25
doc/requirements.txt Normal file
View file

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

1
doc/tutorial/.ghci Normal file
View file

@ -0,0 +1 @@
:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing -itest

339
doc/tutorial/ApiType.lhs Normal file
View file

@ -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&param=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`.

427
doc/tutorial/Authentication.lhs Normal file
View file

@ -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))
```

150
doc/tutorial/Client.lhs Normal file
View file

@ -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**!

234
doc/tutorial/Docs.lhs Normal file
View file

@ -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.

228
doc/tutorial/Javascript.lhs Normal file
View file

@ -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.

4
servant-examples/LICENSE → doc/tutorial/LICENSE
View file

@ -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.

1115
doc/tutorial/Server.lhs Normal file
View file

File diff suppressed because it is too large Load diff

2
doc/tutorial/Setup.hs Normal file
View file

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

24
doc/tutorial/index.rst Normal file
View file

@ -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 <https://haskell-servant.github.io/tutorial/>`_.
(Any comments, issues or feedback about the tutorial can be handled
through
`servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
.. toctree::
:maxdepth: 1
ApiType.lhs
Server.lhs
Client.lhs
Javascript.lhs
Docs.lhs
Authentication.lhs

4
servant-examples/tutorial/t9/index.html → doc/tutorial/static/index.html
View file

@ -3,11 +3,11 @@
<head>
<meta name="viewport" content="width=device-width, initial-scale=1">
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
<title>Tutorial - 9 - servant-jquery</title>
<title>servant-js Example</title>
</head>
<body>
<h1>Books</h1>
<input type="search" name="q" id="q" placeholder="Search author or book title..." />
<input type="search" name="q" id="q" placeholder="Search author or book title..." autocomplete="off"/>
<div>
<p>Results for <strong id="query">""</strong></p>
<ul id="results">

1
servant-examples/tutorial/t9/ui.js → doc/tutorial/static/ui.js
View file

@ -58,4 +58,3 @@ function refresh()
}
window.setInterval(refresh, 200);

32
doc/tutorial/test/JavascriptSpec.hs Normal file
View file

@ -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

1
doc/tutorial/test/Spec.hs Normal file
View file

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

13
doc/tutorial/tinc.yaml Normal file
View file

@ -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

65
doc/tutorial/tutorial.cabal Normal file
View file

@ -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

8
scripts/README.md Normal file
View file

@ -0,0 +1,8 @@
The release process works roughly like this:
``` bash
./scripts/bump-versions.sh <type-of-bump>
git commit
./scripts/upload.hs
git tag <version> && git push --tags
```

7
scripts/bump-versions.sh
View file

@ -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

14
scripts/upload.hs Executable file
View file

@ -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)

52
scripts/upload.sh
View file

@ -1,52 +0,0 @@
#!/usr/bin/env bash
#===============================================================================
#
# FILE: upload.sh
#
# USAGE: ./upload.sh <USER> <PASSWORD>
#
# 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 <USER> <PASSWORD>"
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

2
servant-blaze/LICENSE
View file

@ -1,4 +1,4 @@
Copyright (c) 2015, Julian K. Arni
Copyright (c) 2015-2016, Servant Contributors
All rights reserved.

8
servant-blaze/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

13
servant-blaze/servant-blaze.cabal
View file

@ -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

16
servant-blaze/src/Servant/HTML/Blaze.hs
View file

@ -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

2
servant-cassava/LICENSE
View file

@ -1,4 +1,4 @@
Copyright (c) 2015, Julian K. Arni
Copyright (c) 2015-2016, Servant Contributors
All rights reserved.

8
servant-cassava/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

13
servant-cassava/servant-cassava.cabal
View file

@ -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

14
servant-client/CHANGELOG.md
View file

@ -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
-----

2
servant-client/LICENSE
View file

@ -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.

8
servant-client/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

23
servant-client/servant-client.cabal
View file

@ -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:
<https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
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

377
servant-client/src/Servant/Client.hs
View file

@ -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).
-}

36
servant-client/src/Servant/Client/Experimental/Auth.hs Normal file
View file

@ -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)

21
servant-client/src/Servant/Common/BasicAuth.hs Normal file
View file

@ -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

40
servant-client/src/Servant/Common/Req.hs
View file

@ -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
performRequest :: Method -> Req -> Manager -> BaseUrl
-> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req reqHost manager = do
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)

8
servant-client/stack-ghcjs.yaml
View file

@ -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-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

264
servant-client/test/Servant/ClientSpec.hs
View file

@ -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,11 +203,57 @@ 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
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@ -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

1
servant-docs/.ghci Normal file
View file

@ -0,0 +1 @@
:set -itest -isrc -Iinclude

3
servant-docs/CHANGELOG.md
View file

@ -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
---

2
servant-docs/LICENSE
View file

@ -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.

8
servant-docs/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

12
servant-docs/servant-docs.cabal
View file

@ -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:
<https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>
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

3
servant-docs/src/Servant/Docs.hs
View file

@ -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

244
servant-docs/src/Servant/Docs/Internal.hs
View file

@ -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
, _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

32
servant-docs/test/Servant/DocsSpec.hs
View file

@ -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)

2
servant-examples/Setup.hs
View file

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

80
servant-examples/auth-combinator/auth-combinator.hs
View file

@ -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.
-}

90
servant-examples/hackage/hackage.hs
View file

@ -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"

130
servant-examples/servant-examples.cabal
View file

@ -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

109
servant-examples/socket-io-chat/Chat.hs
View file

@ -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)

28
servant-examples/socket-io-chat/resources/index.html
View file

@ -1,28 +0,0 @@
<!doctype html>
<html lang="en">
<head>
<meta charset="UTF-8">
<title>Socket.IO Chat Example</title>
<link rel="stylesheet" href="style.css">
</head>
<body>
<ul class="pages">
<li class="chat page">
<div class="chatArea">
<ul class="messages"></ul>
</div>
<input class="inputMessage" placeholder="Type here..."/>
</li>
<li class="login page">
<div class="form">
<h3 class="title">What's your nickname?</h3>
<input class="usernameInput" type="text" maxlength="14" />
</div>
</li>
</ul>
<script src="https://cdn.socket.io/socket.io-1.2.1.js"></script>
<script src="https://code.jquery.com/jquery-1.10.2.min.js"></script>
<script src="/main.js"></script>
</body>
</html>

274
servant-examples/socket-io-chat/resources/main.js
View file

@ -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 = $('<li>').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 = $('<span class="username"/>')
.text(data.username)
.css('color', getUsernameColor(data.username));
var $messageBodyDiv = $('<span class="messageBody">')
.text(data.message);
var typingClass = data.typing ? 'typing' : '';
var $messageDiv = $('<li class="message"/>')
.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 $('<div/>').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 &mdash; ";
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);
});
});

150
servant-examples/socket-io-chat/resources/style.css
View file

@ -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%;
}

54
servant-examples/socket-io-chat/socket-io-chat.hs
View file

@ -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

15
servant-examples/tinc.yaml
View file

@ -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

45
servant-examples/tutorial/T1.hs
View file

@ -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

71
servant-examples/tutorial/T10.hs
View file

@ -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

52
servant-examples/tutorial/T2.hs
View file

@ -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

84
servant-examples/tutorial/T3.hs
View file

@ -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

63
servant-examples/tutorial/T4.hs
View file

@ -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

37
servant-examples/tutorial/T5.hs
View file

@ -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

18
servant-examples/tutorial/T6.hs
View file

@ -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

33
servant-examples/tutorial/T7.hs
View file

@ -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

49
servant-examples/tutorial/T8.hs
View file

@ -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

105
servant-examples/tutorial/T9.hs
View file

@ -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'

4
servant-examples/tutorial/t8-main.hs
View file

@ -1,4 +0,0 @@
import T8
main :: IO ()
main = run

39
servant-examples/tutorial/tutorial.hs
View file

@ -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."

51
servant-examples/wai-middleware/wai-middleware.hs
View file

@ -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

3
servant-foreign/CHANGELOG.md
View file

@ -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

2
servant-foreign/LICENSE
View file

@ -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.

8
servant-foreign/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

48
servant-foreign/servant-foreign.cabal
View file

@ -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:
<https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>
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
exposed-modules: Servant.Foreign
, Servant.Foreign.Internal
, Servant.Foreign.Inflections
build-depends: base == 4.*
, lens == 4.*
, servant == 0.5.*
, 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

57
servant-foreign/src/Servant/Foreign.hs
View file

@ -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
, Url(..)
-- aliases
, Path
, Arg(..)
, FunctionName(..)
, PathSegment(..)
-- lenses
, argType
, 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
, 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

45
servant-foreign/src/Servant/Foreign/Inflections.hs Normal file
View file

@ -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

463
servant-foreign/src/Servant/Foreign/Internal.hs
View file

@ -1,117 +1,138 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
#if !MIN_VERSION_base(4,8,0)
{-# 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 Data.Text.Encoding (decodeUtf8)
import GHC.Exts (Constraint)
import GHC.TypeLits
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
data QueryArg f = QueryArg
{ _queryArgName :: Arg f
, _queryArgType :: ArgType
}
| ReplaceHeaderArg
{ headerArg :: Arg
, headerPattern :: Text
} deriving (Eq, Show)
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
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 req =
foreignFor lang (Proxy :: Proxy sublayout) $
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy (Proxy :: Proxy sublayout) $
req & reqUrl . path <>~ [Segment (Cap arg)]
& funcName %~ (++ ["by", str])
& reqFuncName . _FunctionName %~ (++ ["by", str])
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (str, typeFor lang (Proxy :: Proxy a))
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
foreignFor lang Proxy req =
req & funcName %~ ("get" :)
& reqMethod .~ "GET"
& reqReturnType .~ retType
where
retType = typeFor lang (Proxy :: Proxy a)
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout)
=> HasForeign lang (Header sym a :> sublayout) where
type Foreign (Header sym a :> sublayout) = Foreign sublayout
foreignFor lang Proxy req =
foreignFor lang subP $ req
& reqHeaders <>~ [HeaderArg arg]
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 Proxy req =
foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]
where
hname = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (hname, typeFor lang (Proxy :: Proxy a))
arg = Arg
{ _argName = PathSegment hname
, _argType = typeFor lang (Proxy :: Proxy ftype) (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
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 =
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))
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]))
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))
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)
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)

74
servant-foreign/test/Servant/ForeignSpec.hs
View file

@ -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
#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,8 +47,8 @@ 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
@ -66,24 +61,24 @@ listFromAPISpec = describe "listFromAPI" $ do
shouldBe getReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test" ]
[ QueryArg ("flag", "boolX") Flag ]
[ QueryArg (Arg "flag" "boolX") Flag ]
, _reqMethod = "GET"
, _reqHeaders = [HeaderArg ("header", "listX of stringX")]
, _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"]
, _reqBody = Nothing
, _reqReturnType = "intX"
, _funcName = ["get", "test"]
, _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 ]
[ QueryArg (Arg "param" "intX") Normal ]
, _reqMethod = "POST"
, _reqHeaders = []
, _reqBody = Just "listX of stringX"
, _reqReturnType = "voidX"
, _funcName = ["post", "test"]
, _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["post", "test"]
}
it "collects all info for put request" $ do
@ -91,24 +86,23 @@ listFromAPISpec = describe "listFromAPI" $ do
{ _reqUrl = Url
[ Segment $ Static "test" ]
-- Shoud this be |intX| or |listX of intX| ?
[ QueryArg ("params", "listX of intX") List ]
[ QueryArg (Arg "params" "listX of intX") List ]
, _reqMethod = "PUT"
, _reqHeaders = []
, _reqBody = Just "stringX"
, _reqReturnType = "voidX"
, _funcName = ["put", "test"]
, _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 ("id", "intX") ]
, Segment $ Cap (Arg "id" "intX") ]
[]
, _reqMethod = "DELETE"
, _reqHeaders = []
, _reqBody = Nothing
, _reqReturnType = "voidX"
, _funcName = ["delete", "test", "by", "id"]
, _reqReturnType = Just "voidX"
, _reqFuncName = FunctionName ["delete", "test", "by", "id"]
}

4
servant-js/CHANGELOG.md
View file

@ -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

2
servant-js/LICENSE
View file

@ -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.

8
servant-js/include/overlapping-compat.h Normal file
View file

@ -0,0 +1,8 @@
#if __GLASGOW_HASKELL__ >= 710
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
#define OVERLAPPING_ {-# OVERLAPPING #-}
#else
{-# LANGUAGE OverlappingInstances #-}
#define OVERLAPPABLE_
#define OVERLAPPING_
#endif

20
servant-js/servant-js.cabal
View file

@ -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:
<https://github.com/haskell-servant/servant/blob/master/servant-js/CHANGELOG.md CHANGELOG>
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

10
servant-js/src/Servant/JS.hs
View file

@ -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

19
servant-js/src/Servant/JS/Angular.hs
View file

@ -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,7 +90,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
0 -> ["$http"]
_ -> []
captures = map (fst . captureArg)
captures = map (view argPath . captureArg)
. filter isCapture
$ req ^. reqUrl . path
@ -109,9 +113,10 @@ generateAngularJSWith ngOptions opts req = "\n" <>
then ""
else " , headers: { " <> headersStr <> " }\n"
where headersStr = T.intercalate ", " $ map headerStr hs
where
headersStr = T.intercalate ", " $ map headerStr hs
headerStr header = "\"" <>
fst (headerArg header) <>
header ^. headerArg . argPath <>
"\": " <> toJSHeader header
namespace =
@ -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'

19
servant-js/src/Servant/JS/Axios.hs
View file

@ -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,9 +107,10 @@ generateAxiosJSWith aopts opts req = "\n" <>
then ""
else " , headers: { " <> headersStr <> " }\n"
where headersStr = T.intercalate ", " $ map headerStr hs
where
headersStr = T.intercalate ", " $ map headerStr hs
headerStr header = "\"" <>
fst (headerArg header) <>
header ^. headerArg . argPath <>
"\": " <> toJSHeader header
namespace =
@ -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

70
servant-js/src/Servant/JS/Internal.hs
View file

@ -1,4 +1,6 @@
{-# 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

20
servant-js/src/Servant/JS/JQuery.hs
View file

@ -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
where
headersStr = T.intercalate ", " $ map headerStr hs
headerStr header = "\"" <>
fst (headerArg 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'

24
servant-js/src/Servant/JS/Vanilla.hs
View file

@ -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
where
headersStr = T.intercalate "\n" $ map headerStr hs
headerStr header = " xhr.setRequestHeader(\"" <>
fst (headerArg 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'

23
servant-js/test/Servant/JSSpec.hs
View file

@ -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

34
servant-js/test/Servant/JSSpec/CustomHeaders.hs
View file

@ -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."

Some files were not shown because too many files have changed in this diff Show more