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

Merge branch 'master' of https://github.com/haskell-servant/servant into servant-dates

Browse source 
# Conflicts:
#	servant-server/servant-server.cabal
#	servant-server/src/Servant/Server/Internal.hs
#	servant-server/test/Servant/ServerSpec.hs
#	servant/servant.cabal
#	servant/src/Servant/API.hs
This commit is contained in:
Alex Mason 2016-09-02 12:53:04 +10:00
parent 13c2b8e077
commit 6462804f52
166 changed files with 7694 additions and 3519 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 .stack-work
shell.nix shell.nix
default.nix default.nix
doc/_build
doc/venv
doc/tutorial/static/api.js
doc/tutorial/static/jq.js

25
.travis.yml
View file

@ -3,30 +3,27 @@ sudo: false
language: c language: c
env: env:
- GHCVER=7.8.4 - STACK_YAML=stack-ghc-7.8.4.yaml
- GHCVER=7.10.2 - STACK_YAML=stack.yaml
- STACK_YAML=stack-ghc-8.0.1.yaml
addons: addons:
apt: apt:
sources:
- hvr-ghc
packages: packages:
- ghc-7.8.4
- ghc-7.10.2
- cabal-install-1.22
- libgmp-dev - libgmp-dev
install: install:
- (mkdir -p $HOME/.local/bin && cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc) - mkdir -p ~/.local/bin
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.22/bin:$PATH - export PATH=$HOME/.local/bin:$PATH
- ghc --version - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'
- cabal --version - stack --version
- travis_retry cabal update - stack setup --no-terminal
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config - (cd $HOME/.local/bin && wget https://zalora-public.s3.amazonaws.com/tinc && chmod +x tinc)
script: script:
- for package in $(cat sources.txt); do (cd $package && tinc && cabal configure --enable-tests --disable-optimization && cabal build && cabal test) || exit 1; done - if [ "$TRAVIS_EVENT_TYPE" = "cron" ] ; then ./scripts/ci-cron.sh ; else stack test --ghc-options=-Werror --no-terminal ; fi
cache: cache:
directories: directories:
- $HOME/.tinc/cache - $HOME/.tinc/cache
- $HOME/.stack

9
CONTRIBUTING.md
View file

@ -44,7 +44,7 @@ to reopen when the issues have been fixed).
We require two +1 from the maintainers of the repo. If you feel like there has 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 not been a timely response to a PR, you can ping the Maintainers group (with
`@Maintainers`). `@haskell-servant/maintainers`).
## New combinators ## New combinators
@ -77,3 +77,10 @@ the `news` label if you make a new package so we can know about it!
We are currently moving to a more aggresive release policy, so that you can get 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 what you contribute from Hackage fairly soon. However, note that prior to major
releases it may take some time in between releases. 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.

3
README.md
View file

@ -4,11 +4,12 @@
## Getting Started ## Getting Started
We have a [tutorial](http://haskell-servant.github.io/tutorial) that We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that
introduces the core features of servant. After this article, you should be able introduces the core features of servant. After this article, you should be able
to write your first servant webservices, learning the rest from the haddocks' to write your first servant webservices, learning the rest from the haddocks'
examples. examples.
The central documentation can be found [here](http://haskell-servant.readthedocs.org/).
Other blog posts, videos and slides can be found on the Other blog posts, videos and slides can be found on the
[website](http://haskell-servant.github.io/). [website](http://haskell-servant.github.io/).

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,
}

37
doc/examples.md Normal file
View file

@ -0,0 +1,37 @@
# Example Projects
- **[example-servant-minimal](https://github.com/haskell-servant/example-servant-minimal)**:
A minimal example for a web server written using **servant-server**,
including a test-suite using [**hspec**](http://hspec.github.io/) and
**servant-client**.
- **[stack-templates](https://github.com/commercialhaskell/stack-templates)**
Repository for templates for haskell projects, including some templates using
**servant**. These templates can be used with `stack new`.
- **[custom-monad](https://github.com/themoritz/diener)**:
A custom monad that can replace `IO` in servant applications. It adds among
other things logging functionality and a reader monad (for database connections).
A full usage example of servant/diener is also provided.
- **[example-servant-elm](https://github.com/haskell-servant/example-servant-elm)**:
An example for a project consisting of
- a backend web server written using **servant-server**,
- a frontend written in [elm](http://elm-lang.org/) using
[servant-elm](https://github.com/mattjbray/servant-elm) to generate client
functions in elm for the API,
- test-suites for both the backend and the frontend.
- **[example-servant-persistent](https://github.com/haskell-servant/example-servant-persistent)**:
An example for a web server written with **servant-server** and
[persistent](https://www.stackage.org/package/persistent) for writing data
into a database.

23
doc/index.rst Normal file
View file

@ -0,0 +1,23 @@
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
examples.md
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.6
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

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

@ -0,0 +1,347 @@
# 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.
Tip: If your endpoint responds to `/` (the root path), just omit any combinators
that introduce path segments. E.g. the following api has only one endpoint on `/`:
``` haskell
type RootEndpoint =
Get '[JSON] User
```
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 Authentication 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 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 (throwError)
import Servant.Server (BasicAuthCheck (BasicAuthCheck),
BasicAuthResult( Authorized
, Unauthorized
),
Context ((:.), EmptyContext),
err401, err403, errBody, Server,
serveWithContext, Handler)
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 -> Handler 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 -> Handler 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 -> Handler 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 -> Handler` 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 -> Handler 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 -> Handler Account
lookupAccount key = case Map.lookup key database of
Nothing -> throwError (err403 { errBody = "Invalid Cookie" })
Just usr -> return usr
```
For generalized authentication, servant exposes the `AuthHandler` type,
which is used to wrap the `Request -> Handler 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 -> Handler 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 -> throwError (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 -> Handler 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.

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

@ -0,0 +1,518 @@
# 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.JS`.
``` haskell
apiJS1 :: Text
apiJS1 = jsForAPI api jquery
```
This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks':
``` javascript
var getPoint = function(onSuccess, onError)
{
$.ajax(
{ url: '/point'
, success: onSuccess
, error: onError
, type: 'GET'
});
}
var getBooks = function(q, onSuccess, onError)
{
$.ajax(
{ url: '/books' + '?q=' + encodeURIComponent(q)
, success: onSuccess
, error: onError
, type: 'GET'
});
}
```
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" apiJS1
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.
## Customizations
Instead of calling `jquery`, you can call its variant `jqueryWith`.
Here are the type definitions
```haskell ignore
jquery :: JavaScriptGenerator
jqueryWith :: CommonGeneratorOptions -> JavaScriptGenerator
```
The `CommonGeneratorOptions` will let you define different behaviors to
change how functions are generated. Here is the definition of currently
available options:
```haskell ignore
data CommonGeneratorOptions = CommonGeneratorOptions
{
-- | function generating function names
functionNameBuilder :: FunctionName -> Text
-- | name used when a user want to send the request body (to let you redefine it)
, requestBody :: Text
-- | name of the callback parameter when the request was successful
, successCallback :: Text
-- | name of the callback parameter when the request reported an error
, errorCallback :: Text
-- | namespace on which we define the js function (empty mean local var)
, moduleName :: Text
-- | a prefix that should be prepended to the URL in the generated JS
, urlPrefix :: Text
}
```
This pattern is available with all supported backends, and default values are provided.
## Vanilla support
If you don't use JQuery for your application, you can reduce your
dependencies to simply use the `XMLHttpRequest` object from the standard API.
Use the same code as before but simply replace the previous `apiJS` with
the following one:
``` haskell
apiJS2 :: Text
apiJS2 = jsForAPI api vanillaJS
```
The rest is *completely* unchanged.
The output file is a bit different, but it has the same parameters,
``` 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);
}
```
And that's all, your web service can of course be accessible from those
two clients at the same time!
## Axios support
### Simple usage
If you use Axios library for your application, we support that too!
Use the same code as before but simply replace the previous `apiJS` with
the following one:
``` haskell
apiJS3 :: Text
apiJS3 = jsForAPI api $ axios defAxiosOptions
```
The rest is *completely* unchanged.
The output file is a bit different,
``` javascript
var getPoint = function()
{
return axios({ url: '/point'
, method: 'get'
});
}
var getBooks = function(q)
{
return axios({ url: '/books' + '?q=' + encodeURIComponent(q)
, method: 'get'
});
}
```
**Caution:** In order to support the promise style of the API, there are no onSuccess
nor onError callback functions.
### Defining Axios configuration
Axios lets you define a 'configuration' to determine the behavior of the
program when the AJAX request is sent.
We mapped this into a configuration
``` haskell
data AxiosOptions = AxiosOptions
{ -- | indicates whether or not cross-site Access-Control requests
-- should be made using credentials
withCredentials :: !Bool
-- | the name of the cookie to use as a value for xsrf token
, xsrfCookieName :: !(Maybe Text)
-- | the name of the header to use as a value for xsrf token
, xsrfHeaderName :: !(Maybe Text)
}
```
## Angular support
### Simple usage
You can apply the same procedure as with `vanillaJS` and `jquery`, and
generate top level functions.
The difference is that `angular` Generator always takes an argument.
``` haskell
apiJS4 :: Text
apiJS4 = jsForAPI api $ angular defAngularOptions
```
The generated code will be a bit different than previous generators. An extra
argument `$http` will be added to let Angular magical Dependency Injector
operate.
**Caution:** In order to support the promise style of the API, there are no onSuccess
nor onError callback functions.
``` javascript
var getPoint = function($http)
{
return $http(
{ url: '/point'
, method: 'GET'
});
}
var getBooks = function($http, q)
{
return $http(
{ url: '/books' + '?q=' + encodeURIComponent(q)
, method: 'GET'
});
}
```
You can then build your controllers easily
``` javascript
app.controller("MyController", function($http) {
this.getPoint = getPoint($http)
.success(/* Do something */)
.error(/* Report error */);
this.getPoint = getBooks($http, q)
.success(/* Do something */)
.error(/* Report error */);
});
```
### Service generator
You can also generate automatically a service to wrap the whole API as
a single Angular service:
``` javascript
app.service('MyService', function($http) {
return ({
postCounter: function()
{
return $http(
{ url: '/counter'
, method: 'POST'
});
},
getCounter: function()
{
return $http(
{ url: '/books' + '?q=' + encodeURIComponent(q), true);
, method: 'GET'
});
}
});
});
```
To do so, you just have to use an alternate generator.
``` haskell
apiJS5 :: Text
apiJS5 = jsForAPI api $ angularService defAngularOptions
```
Again, it is possible to customize some portions with the options.
``` haskell
data AngularOptions = AngularOptions
{ -- | When generating code with wrapInService, name of the service to generate, default is 'app'
serviceName :: Text
, -- | beginning of the service definition
prologue :: Text -> Text -> Text
, -- | end of the service definition
epilogue :: Text
}
```
# Custom function name builder
Servant comes with three name builders included:
- camelCase (the default)
- concatCase
- snakeCase
Keeping the JQuery as an example, let's see the impact:
``` haskell
apiJS6 :: Text
apiJS6 = jsForAPI api $ jqueryWith defCommonGeneratorOptions { functionNameBuilder= snakeCase }
```
This `Text` contains 2 Javascript functions:
``` javascript
var get_point = function(onSuccess, onError)
{
$.ajax(
{ url: '/point'
, success: onSuccess
, error: onError
, type: 'GET'
});
}
var get_books = function(q, onSuccess, onError)
{
$.ajax(
{ url: '/books' + '?q=' + encodeURIComponent(q)
, success: onSuccess
, error: onError
, type: 'GET'
});
}
```

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

@ -1,4 +1,4 @@
Copyright (c) 2015, Julian K. Arni Copyright (c) 2016, Servant Contributors
All rights reserved. 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 disclaimer in the documentation and/or other materials provided
with the distribution. with the distribution.
* Neither the name of Julian K. Arni 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 contributors may be used to endorse or promote products derived
from this software without specific prior written permission. from this software without specific prior written permission.

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

File diff suppressed because it is too large Load diff

0
servant-cassava/Setup.hs → doc/tutorial/Setup.hs
View file

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

@ -0,0 +1,18 @@
Tutorial
========
This is an introductory tutorial to **servant**.
(Any comments, issues or feedback about the tutorial can be submitted
to `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> <head>
<meta name="viewport" content="width=device-width, initial-scale=1"> <meta name="viewport" content="width=device-width, initial-scale=1">
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" /> <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
<title>Tutorial - 9 - servant-jquery</title> <title>servant-js Example</title>
</head> </head>
<body> <body>
<h1>Books</h1> <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> <div>
<p>Results for <strong id="query">""</strong></p> <p>Results for <strong id="query">""</strong></p>
<ul id="results"> <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); window.setInterval(refresh, 200);

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

@ -0,0 +1,35 @@
{-# 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 apiJS1 `shouldSatisfy` (`isInfixOf` code)
cs apiJS3 `shouldSatisfy` (`isInfixOf` code)
cs apiJS4 `shouldSatisfy` (`isInfixOf` code)
cs apiJS6 `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 apiJS1))
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

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

@ -0,0 +1,62 @@
name: tutorial
version: 0.8
synopsis: The servant tutorial
homepage: http://haskell-servant.readthedocs.org/
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.8.*
, servant-server == 0.8.*
, servant-client == 0.8.*
, servant-docs == 0.8.*
, servant-js == 0.8.*
, 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 -pgmL markdown-unlit
test-suite spec
type: exitcode-stdio-1.0
ghc-options: -Wall
default-language: Haskell2010
hs-source-dirs: test
main-is: Spec.hs
other-modules: JavascriptSpec
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 if $DRY_RUN ; then
echo "Would have bumped position ${POSITION} on these packages:" 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 else
( cd "$ROOT" && bumper -"$POSITION" $(join , "${SOURCES[@]}") ) ( cd "$ROOT" && bumper -"$POSITION" $(join , $SOURCES tutorial) )
fi fi
# Trailing newline, bumper does not ship with its own.
echo

20
scripts/ci-cron.sh Executable file
View file

@ -0,0 +1,20 @@
#!/usr/bin/env bash
set -o nounset
set -o errexit
set -o verbose
export PATH=$(stack path --bin-path):$PATH
stack install cabal-install
cabal update
for package in $(cat sources.txt) ; do
echo testing $package
pushd $package
tinc
cabal configure --enable-tests --disable-optimization --ghc-options='-Werror'
cabal build
cabal test
popd
done

11
scripts/test-stack.sh Executable file
View file

@ -0,0 +1,11 @@
#!/usr/bin/env bash
set -o nounset
set -o errexit
for stack_file in stack*.yaml ; do
echo testing $stack_file...
export STACK_YAML=$stack_file
stack setup
stack test --fast --ghc-options="-Werror"
done

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 --no-signature " ++ 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

30
servant-blaze/LICENSE
View file

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

2
servant-blaze/Setup.hs
View file

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

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

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

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

@ -1,33 +0,0 @@
-- Initial servant-blaze.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: servant-blaze
version: 0.5
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:
category: Web
build-type: Simple
extra-source-files: include/*.h
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
library
exposed-modules: Servant.HTML.Blaze
-- other-modules:
-- other-extensions:
build-depends: base >=4.7 && <5
, servant == 0.5.*
, http-media
, blaze-html
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

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

@ -1,35 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
#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
-- `HTML` datatype.:
--
-- >>> type Eg = Get '[HTML] a
--
-- Will then check that @a@ has a `ToMarkup` instance, or is `Html`.
module Servant.HTML.Blaze where
import Data.Typeable (Typeable)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..))
import Text.Blaze.Html (Html, ToMarkup, toHtml)
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
data HTML deriving Typeable
-- | @text/html;charset=utf-8@
instance Accept HTML where
contentType _ = "text" M.// "html" M./: ("charset", "utf-8")
instance OVERLAPPABLE_ ToMarkup a => MimeRender HTML a where
mimeRender _ = renderHtml . toHtml
instance OVERLAPPING_ MimeRender HTML Html where
mimeRender _ = renderHtml

3
servant-blaze/tinc.yaml
View file

@ -1,3 +0,0 @@
dependencies:
- name: servant
path: ../servant

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

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

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

@ -1,30 +0,0 @@
-- Initial servant-cassava.cabal generated by cabal init. For further
-- documentation, see http://haskell.org/cabal/users-guide/
name: servant-cassava
version: 0.4.4.2
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:
-- category:
build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10
library
exposed-modules: Servant.CSV.Cassava
-- other-modules:
-- other-extensions:
build-depends: base >=4.6 && <5
, cassava >0.4 && <0.5
, servant ==0.5.*
, http-media
, vector
hs-source-dirs: src
default-language: Haskell2010
include-dirs: include

115
servant-cassava/src/Servant/CSV/Cassava.hs
View file

@ -1,115 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | A @CSV@ empty datatype with `MimeRender` and `MimeUnrender` instances for
-- @cassava@'s encoding and decoding classes.
--
-- >>> type Eg = Get '[(CSV', MyEncodeOptions)] [(Int, String)]
--
-- Default encoding and decoding options are also provided, along with the
-- @CSV@ type synonym that uses them.
--
-- >>> type EgDefault = Get '[CSV] [(Int, String)]
module Servant.CSV.Cassava where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.Csv
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable)
import Data.Vector (Vector, toList)
import GHC.Generics (Generic)
import qualified Network.HTTP.Media as M
import Servant.API (Accept (..), MimeRender (..),
MimeUnrender (..))
data CSV' deriving (Typeable, Generic)
type CSV = (CSV', DefaultDecodeOpts)
-- | @text/csv;charset=utf-8@
instance Accept (CSV', a) where
contentType _ = "text" M.// "csv" M./: ("charset", "utf-8")
-- * Encoding
-- ** Instances
-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining
-- the order of headers and fields.
instance ( ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Header, [a]) where
mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr vals
where p = Proxy :: Proxy opt
-- | Encode with 'encodeDefaultOrderedByNameWith'
instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) [a] where
mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p)
where p = Proxy :: Proxy opt
-- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining
-- the order of headers and fields.
instance ( ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Header, Vector a) where
mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals)
where p = Proxy :: Proxy opt
-- | Encode with 'encodeDefaultOrderedByNameWith'
instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt
) => MimeRender (CSV', opt) (Vector a) where
mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList
where p = Proxy :: Proxy opt
-- ** Encode Options
class EncodeOpts a where
encodeOpts :: Proxy a -> EncodeOptions
data DefaultEncodeOpts deriving (Typeable, Generic)
instance EncodeOpts DefaultEncodeOpts where
encodeOpts _ = defaultEncodeOptions
-- * Decoding
-- ** Instances
-- | Decode with 'decodeByNameWith'
instance ( FromNamedRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Header, [a]) where
mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs
where p = Proxy :: Proxy opt
-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped.
instance ( FromRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) [a] where
mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs
where p = Proxy :: Proxy opt
instance ( FromNamedRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Header, Vector a) where
mimeUnrender _ = decodeByNameWith (decodeOpts p)
where p = Proxy :: Proxy opt
-- | Decode with 'decodeWith'. Assumes data has headers, which are stripped.
instance ( FromRecord a, DecodeOpts opt
) => MimeUnrender (CSV', opt) (Vector a) where
mimeUnrender _ = decodeWith (decodeOpts p) HasHeader
where p = Proxy :: Proxy opt
-- ** Decode Options
class DecodeOpts a where
decodeOpts :: Proxy a -> DecodeOptions
data DefaultDecodeOpts deriving (Typeable, Generic)
instance DecodeOpts DefaultDecodeOpts where
decodeOpts _ = defaultDecodeOptions

3
servant-cassava/tinc.yaml
View file

@ -1,3 +0,0 @@
dependencies:
- name: servant
path: ../servant

20
servant-client/CHANGELOG.md
View file

@ -1,13 +1,27 @@
HEAD 0.7.1
---- -----
* Support GHC 8.0
* `ServantError` has an `Eq` instance now.
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`. * Use the `text` package instead of `String`.
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Added support for `path` on `BaseUrl`. * Added support for `path` on `BaseUrl`.
* `client` now takes an explicit `Manager` argument. * `client` now takes an explicit `Manager` argument.
* Use `http-api-data` instead of `Servant.Common.Text` * 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. * Remove matrix params.
* Added support for Basic authentication
* Add generalized authentication support via the `AuthClientData` type family and
`AuthenticateReq` data type
0.4.1 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. All rights reserved.

7
servant-client/README.md
View file

@ -13,9 +13,8 @@ type MyApi = "books" :> Get '[JSON] [Book] -- GET /books
myApi :: Proxy MyApi myApi :: Proxy MyApi
myApi = Proxy myApi = Proxy
getAllBooks :: ExceptT String IO [Book] getAllBooks :: Manager -> BaseUrl -> ExceptT String IO [Book]
postNewBook :: Book -> ExceptT String IO Book postNewBook :: Book -> Manager -> BaseUrl -> ExceptT String IO Book
-- 'client' allows you to produce operations to query an API from a client. -- 'client' allows you to produce operations to query an API from a client.
(getAllBooks :<|> postNewBook) = client myApi host (getAllBooks :<|> postNewBook) = client myApi
where host = BaseUrl Http "localhost" 8080
``` ```

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

@ -1,25 +1,28 @@
name: servant-client name: servant-client
version: 0.5 version: 0.8
synopsis: automatical derivation of querying functions for servant webservices synopsis: automatical derivation of querying functions for servant webservices
description: description:
This library lets you derive automatically Haskell functions that This library lets you derive automatically Haskell functions that
let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice. let you query each endpoint of a <http://hackage.haskell.org/package/servant servant> webservice.
. .
See <http://haskell-servant.github.io/tutorial/client.html the client section of the tutorial>. See <http://haskell-servant.readthedocs.org/en/stable/tutorial/Client.html the client section of the tutorial>.
. .
<https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG> <https://github.com/haskell-servant/servant/blob/master/servant-client/CHANGELOG.md CHANGELOG>
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni author: Servant Contributors
maintainer: alpmestan@gmail.com maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014 Zalora South East Asia Pte Ltd copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
category: Web category: Web
build-type: Simple build-type: Simple
extra-source-files: include/*.h
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC >= 7.8 tested-with: GHC >= 7.8
homepage: http://haskell-servant.github.io/ homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files:
include/*.h
CHANGELOG.md
README.md
source-repository head source-repository head
type: git type: git
location: http://github.com/haskell-servant/servant.git location: http://github.com/haskell-servant/servant.git
@ -27,35 +30,39 @@ source-repository head
library library
exposed-modules: exposed-modules:
Servant.Client Servant.Client
Servant.Client.Experimental.Auth
Servant.Common.BaseUrl Servant.Common.BaseUrl
Servant.Common.BasicAuth
Servant.Common.Req Servant.Common.Req
build-depends: build-depends:
base >=4.7 && <5 base >= 4.7 && < 4.10
, aeson , aeson >= 0.7 && < 1.1
, attoparsec , attoparsec >= 0.12 && < 0.14
, bytestring , base64-bytestring >= 1.0.0.1 && < 1.1
, exceptions , bytestring >= 0.10 && < 0.11
, http-api-data >= 0.1 && < 0.3 , exceptions >= 0.8 && < 0.9
, http-client , http-api-data >= 0.1 && < 0.3
, http-client-tls , http-client >= 0.4.18.1 && < 0.6
, http-media , http-client-tls >= 0.2.2 && < 0.4
, http-types , http-media >= 0.6.2 && < 0.7
, network-uri >= 2.6 , http-types >= 0.8.6 && < 0.10
, safe , network-uri >= 2.6 && < 2.7
, servant == 0.5.* , safe >= 0.3.9 && < 0.4
, string-conversions , servant == 0.8.*
, text , string-conversions >= 0.3 && < 0.5
, transformers , text >= 1.2 && < 1.3
, transformers-compat , transformers >= 0.3 && < 0.6
, transformers-compat >= 0.4 && < 0.6
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include include-dirs: include
test-suite spec test-suite spec
type: exitcode-stdio-1.0 type: exitcode-stdio-1.0
ghc-options: ghc-options: -Wall
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
default-language: Haskell2010 default-language: Haskell2010
hs-source-dirs: test hs-source-dirs: test
main-is: Spec.hs main-is: Spec.hs
@ -76,9 +83,9 @@ test-suite spec
, HUnit , HUnit
, network >= 2.6 , network >= 2.6
, QuickCheck >= 2.7 , QuickCheck >= 2.7
, servant == 0.5.* , servant == 0.8.*
, servant-client , servant-client
, servant-server == 0.5.* , servant-server == 0.8.*
, text , text
, wai , wai
, warp , warp

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

@ -15,8 +15,12 @@
-- querying functions for each endpoint just from the type representing your -- querying functions for each endpoint just from the type representing your
-- API. -- API.
module Servant.Client module Servant.Client
( client ( AuthClientData
, AuthenticateReq(..)
, client
, HasClient(..) , HasClient(..)
, ClientM
, mkAuthenticateReq
, ServantError(..) , ServantError(..)
, module Servant.Common.BaseUrl , module Servant.Common.BaseUrl
) where ) where
@ -24,19 +28,20 @@ module Servant.Client
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Control.Monad.Trans.Except
import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy (ByteString)
import Data.List import Data.List
import Data.Proxy import Data.Proxy
import Data.String.Conversions import Data.String.Conversions
import Data.Text (unpack) import Data.Text (unpack)
import GHC.TypeLits import GHC.TypeLits
import Network.HTTP.Client (Response, Manager) import Network.HTTP.Client (Manager, Response)
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Header as HTTP
import Servant.API import Servant.API
import Servant.Client.Experimental.Auth
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
import Servant.Common.BasicAuth
import Servant.Common.Req import Servant.Common.Req
-- * Accessing APIs as a Client -- * Accessing APIs as a Client
@ -49,19 +54,18 @@ import Servant.Common.Req
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > getAllBooks :: ExceptT String IO [Book] -- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
-- > postNewBook :: Book -> ExceptT String IO Book -- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi host manager -- > (getAllBooks :<|> postNewBook) = client myApi
-- > where host = BaseUrl Http "localhost" 8080 client :: HasClient api => Proxy api -> Client api
client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout client p = clientWithRoute p defReq
client p baseurl = clientWithRoute p defReq baseurl
-- | This class lets us define how each API combinator -- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly -- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'. -- an internal class, you can just use 'client'.
class HasClient layout where class HasClient api where
type Client layout :: * type Client api :: *
clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout clientWithRoute :: Proxy api -> Req -> Client api
-- | A client querying function for @a ':<|>' b@ will actually hand you -- | A client querying function for @a ':<|>' b@ will actually hand you
@ -74,15 +78,14 @@ class HasClient layout where
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > getAllBooks :: ExceptT String IO [Book] -- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
-- > postNewBook :: Book -> ExceptT String IO Book -- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi host manager -- > (getAllBooks :<|> postNewBook) = client myApi
-- > where host = BaseUrl Http "localhost" 8080
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|> clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req baseurl manager clientWithRoute (Proxy :: Proxy b) req
-- | If you use a 'Capture' in one of your endpoints in your API, -- | If you use a 'Capture' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -100,38 +103,68 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > getBook :: Text -> ExceptT String IO Book -- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book
-- > getBook = client myApi host manager -- > getBook = client myApi
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "getBook" to query that endpoint -- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout) instance (KnownSymbol capture, ToHttpApiData a, HasClient api)
=> HasClient (Capture capture a :> sublayout) where => HasClient (Capture capture a :> api) where
type Client (Capture capture a :> sublayout) = type Client (Capture capture a :> api) =
a -> Client sublayout a -> Client api
clientWithRoute Proxy req baseurl manager val = clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy api)
(appendToPath p req) (appendToPath p req)
baseurl
manager
where p = unpack (toUrlPiece val) where p = unpack (toUrlPiece val)
-- | If you use a 'CaptureAll' in one of your endpoints in your API,
-- the corresponding querying function will automatically take an
-- additional argument of a list of the type specified by your
-- 'CaptureAll'. That function will take care of inserting a textual
-- representation of this value at the right place in the request
-- path.
--
-- You can control how these values are turned into text by specifying
-- a 'ToHttpApiData' instance of your type.
--
-- Example:
--
-- > type MyAPI = "src" :> CaptureAll Text -> Get '[JSON] SourceFile
-- >
-- > myApi :: Proxy
-- > myApi = Proxy
--
-- > getSourceFile :: [Text] -> Manager -> BaseUrl -> ClientM SourceFile
-- > getSourceFile = client myApi
-- > -- then you can use "getSourceFile" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
=> HasClient (CaptureAll capture a :> sublayout) where
type Client (CaptureAll capture a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req vals =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (flip appendToPath) req ps)
where ps = map (unpack . toUrlPiece) vals
instance OVERLAPPABLE_ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types] -- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts) (MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where ) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = ExceptT ServantError IO a type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req manager baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where (ReflectMethod method) => HasClient (Verb method status cts NoContent) where
type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent type Client (Verb method status cts NoContent)
clientWithRoute Proxy req baseurl manager = = Manager -> BaseUrl -> ClientM NoContent
performRequestNoBody method req baseurl manager >> return NoContent clientWithRoute Proxy req manager baseurl =
performRequestNoBody method req manager baseurl >> return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
@ -139,10 +172,10 @@ instance OVERLAPPING_
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts) ( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where ) => HasClient (Verb method status cts' (Headers ls a)) where
type Client (Verb method status cts' (Headers ls a)) type Client (Verb method status cts' (Headers ls a))
= ExceptT ServantError IO (Headers ls a) = Manager -> BaseUrl -> ClientM (Headers ls a)
clientWithRoute Proxy req baseurl manager = do clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -151,10 +184,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method ( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where ) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent)) type Client (Verb method status cts (Headers ls NoContent))
= ExceptT ServantError IO (Headers ls NoContent) = Manager -> BaseUrl -> ClientM (Headers ls NoContent)
clientWithRoute Proxy req baseurl manager = do clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req baseurl manager hdrs <- performRequestNoBody method req manager baseurl
return $ Headers { getResponse = NoContent return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -173,7 +206,7 @@ instance OVERLAPPING_
-- Example: -- Example:
-- --
-- > newtype Referer = Referer { referrer :: Text } -- > newtype Referer = Referer { referrer :: Text }
-- > deriving (Eq, Show, Generic, FromText, ToHttpApiData) -- > deriving (Eq, Show, Generic, ToHttpApiData)
-- > -- >
-- > -- GET /view-my-referer -- > -- GET /view-my-referer
-- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer -- > type MyApi = "view-my-referer" :> Header "Referer" Referer :> Get '[JSON] Referer
@ -181,28 +214,36 @@ instance OVERLAPPING_
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > viewReferer :: Maybe Referer -> ExceptT String IO Book -- > viewReferer :: Maybe Referer -> Manager -> BaseUrl -> ClientM Book
-- > viewReferer = client myApi host -- > viewReferer = client myApi
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "viewRefer" to query that endpoint -- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments -- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
=> HasClient (Header sym a :> sublayout) where => HasClient (Header sym a :> api) where
type Client (Header sym a :> sublayout) = type Client (Header sym a :> api) =
Maybe a -> Client sublayout Maybe a -> Client api
clientWithRoute Proxy req baseurl manager mval = clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy api)
(maybe req (maybe req
(\value -> Servant.Common.Req.addHeader hname value req) (\value -> Servant.Common.Req.addHeader hname value req)
mval mval
) )
baseurl
manager
where hname = symbolVal (Proxy :: Proxy sym) where hname = symbolVal (Proxy :: Proxy sym)
-- | Using a 'HttpVersion' combinator in your API doesn't affect the client
-- functions.
instance HasClient api
=> HasClient (HttpVersion :> api) where
type Client (HttpVersion :> api) =
Client api
clientWithRoute Proxy =
clientWithRoute (Proxy :: Proxy api)
-- | If you use a 'QueryParam' in one of your endpoints in your API, -- | If you use a 'QueryParam' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
-- an additional argument of the type specified by your 'QueryParam', -- an additional argument of the type specified by your 'QueryParam',
@ -223,27 +264,24 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > getBooksBy :: Maybe Text -> ExceptT String IO [Book] -- > getBooksBy :: Maybe Text -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooksBy = client myApi host -- > getBooksBy = client myApi
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy Nothing' for all books -- > -- 'getBooksBy Nothing' for all books
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov -- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
=> HasClient (QueryParam sym a :> sublayout) where => HasClient (QueryParam sym a :> api) where
type Client (QueryParam sym a :> sublayout) = type Client (QueryParam sym a :> api) =
Maybe a -> Client sublayout Maybe a -> Client api
-- if mparam = Nothing, we don't add it to the query string -- 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) clientWithRoute (Proxy :: Proxy api)
(maybe req (maybe req
(flip (appendToQueryString pname) req . Just) (flip (appendToQueryString pname) req . Just)
mparamText mparamText
) )
baseurl
manager
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -270,26 +308,24 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > getBooksBy :: [Text] -> ExceptT String IO [Book] -- > getBooksBy :: [Text] -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooksBy = client myApi host -- > getBooksBy = client myApi
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "getBooksBy" to query that endpoint. -- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy []' for all books -- > -- 'getBooksBy []' for all books
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]' -- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
-- > -- to get all books by Asimov and Heinlein -- > -- to get all books by Asimov and Heinlein
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout) instance (KnownSymbol sym, ToHttpApiData a, HasClient api)
=> HasClient (QueryParams sym a :> sublayout) where => HasClient (QueryParams sym a :> api) where
type Client (QueryParams sym a :> sublayout) = type Client (QueryParams sym a :> api) =
[a] -> Client sublayout [a] -> Client api
clientWithRoute Proxy req baseurl manager paramlist = clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy api)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req req
paramlist' paramlist'
) )
baseurl manager
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -311,25 +347,23 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > getBooks :: Bool -> ExceptT String IO [Book] -- > getBooks :: Bool -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooks = client myApi host -- > getBooks = client myApi
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "getBooks" to query that endpoint. -- > -- then you can just use "getBooks" to query that endpoint.
-- > -- 'getBooksBy False' for all books -- > -- 'getBooksBy False' for all books
-- > -- 'getBooksBy True' to only get _already published_ books -- > -- 'getBooksBy True' to only get _already published_ books
instance (KnownSymbol sym, HasClient sublayout) instance (KnownSymbol sym, HasClient api)
=> HasClient (QueryFlag sym :> sublayout) where => HasClient (QueryFlag sym :> api) where
type Client (QueryFlag sym :> sublayout) = type Client (QueryFlag sym :> api) =
Bool -> Client sublayout Bool -> Client api
clientWithRoute Proxy req baseurl manager flag = clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy api)
(if flag (if flag
then appendToQueryString paramname Nothing req then appendToQueryString paramname Nothing req
else req else req
) )
baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -337,11 +371,12 @@ instance (KnownSymbol sym, HasClient sublayout)
-- | Pick a 'Method' and specify where the server you want to query is. You get -- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where 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 Raw -> Req -> Client Raw
clientWithRoute Proxy req baseurl manager httpMethod = do clientWithRoute Proxy req httpMethod = do
performRequest httpMethod req baseurl manager performRequest httpMethod req
-- | If you use a 'ReqBody' in one of your endpoints in your API, -- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -358,53 +393,72 @@ instance HasClient Raw where
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > addBook :: Book -> ExceptT String IO Book -- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > addBook = client myApi host manager -- > addBook = client myApi
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "addBook" to query that endpoint -- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient sublayout) instance (MimeRender ct a, HasClient api)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where => HasClient (ReqBody (ct ': cts) a :> api) where
type Client (ReqBody (ct ': cts) a :> sublayout) = type Client (ReqBody (ct ': cts) a :> api) =
a -> Client sublayout a -> Client api
clientWithRoute Proxy req baseurl manager body = clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy api)
(let ctProxy = Proxy :: Proxy ct (let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body) in setRQBody (mimeRender ctProxy body)
(contentType ctProxy) (contentType ctProxy)
req req
) )
baseurl manager
-- | Make the querying function append @path@ to the request path. -- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where instance (KnownSymbol path, HasClient api) => HasClient (path :> api) where
type Client (path :> sublayout) = Client sublayout type Client (path :> api) = Client api
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy api)
(appendToPath p req) (appendToPath p req)
baseurl manager
where p = symbolVal (Proxy :: Proxy path) where p = symbolVal (Proxy :: Proxy path)
instance HasClient api => HasClient (Vault :> api) where instance HasClient api => HasClient (Vault :> api) where
type Client (Vault :> api) = Client api type Client (Vault :> api) = Client api
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req baseurl manager clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (RemoteHost :> api) where instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api type Client (RemoteHost :> api) = Client api
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req baseurl manager clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (IsSecure :> api) where instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api type Client (IsSecure :> api) = Client api
clientWithRoute Proxy req baseurl manager = clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy api) req baseurl manager 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] {- Note [Non-Empty Content Types]

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

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

@ -55,6 +55,19 @@ data ServantError
} }
deriving (Show, Typeable) deriving (Show, Typeable)
instance Eq ServantError where
FailureResponse a b c == FailureResponse x y z =
(a, b, c) == (x, y, z)
DecodeFailure a b c == DecodeFailure x y z =
(a, b, c) == (x, y, z)
UnsupportedContentType a b == UnsupportedContentType x y =
(a, b) == (x, y)
InvalidContentTypeHeader a b == InvalidContentTypeHeader x y =
(a, b) == (x, y)
ConnectionError a == ConnectionError x =
show a == show x
_ == _ = False
instance Exception ServantError instance Exception ServantError
data Req = Req data Req = Req
@ -90,7 +103,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) = reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
setheaders . setAccept . setrqb . setQS <$> parseUrl url setheaders . setAccept . setrqb . setQS <$> parseRequest url
where url = show $ nullURI { uriScheme = case reqScheme of where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:" Http -> "http:"
@ -117,22 +130,34 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
toProperHeader (name, val) = toProperHeader (name, val) =
(fromString name, encodeUtf8 val) (fromString name, encodeUtf8 val)
#if !MIN_VERSION_http_client(0,4,30)
-- 'parseRequest' is introduced in http-client-0.4.30
-- it differs from 'parseUrl', by not throwing exceptions on non-2xx http statuses
--
-- See for implementations:
-- http://hackage.haskell.org/package/http-client-0.4.30/docs/src/Network-HTTP-Client-Request.html#parseRequest
-- http://hackage.haskell.org/package/http-client-0.5.0/docs/src/Network-HTTP-Client-Request.html#parseRequest
parseRequest :: MonadThrow m => String -> m Request
parseRequest url = liftM disableStatusCheck (parseUrl url)
where
disableStatusCheck req = req { checkStatus = \ _status _headers _cookies -> Nothing }
#endif
-- * performing requests -- * performing requests
displayHttpRequest :: Method -> String displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
type ClientM = ExceptT ServantError IO
performRequest :: Method -> Req -> BaseUrl -> Manager performRequest :: Method -> Req -> Manager -> BaseUrl
-> ExceptT ServantError IO ( Int, ByteString, MediaType -> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString) , [HTTP.Header], Response ByteString)
performRequest reqMethod req reqHost manager = do performRequest reqMethod req manager reqHost = do
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod let request = partialRequest { Client.method = reqMethod }
, checkStatus = \ _status _headers _cookies -> Nothing
}
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of case eResponse of
@ -153,23 +178,22 @@ performRequest reqMethod req reqHost manager = do
throwE $ FailureResponse status ct body throwE $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response) return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result => performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> BaseUrl -> Manager Proxy ct -> Method -> Req -> Manager -> BaseUrl
-> ExceptT ServantError IO ([HTTP.Header], result) -> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req reqHost manager = do performRequestCT ct reqMethod req manager reqHost = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <- (_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val) Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> BaseUrl -> Manager performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
-> ExceptT ServantError IO [HTTP.Header] -> ClientM [HTTP.Header]
performRequestNoBody reqMethod req reqHost manager = do performRequestNoBody reqMethod req manager reqHost = do
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError :: IO a -> IO (Either ServantError a)

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

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
@ -11,9 +12,14 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -freduction-depth=100 #-}
#else
{-# OPTIONS_GHC -fcontext-stack=100 #-} {-# OPTIONS_GHC -fcontext-stack=100 #-}
#endif
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
@ -26,21 +32,20 @@ import Control.Applicative ((<$>))
import Control.Arrow (left) import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId) import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket) import Control.Exception (bracket)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Control.Monad.Trans.Except (throwE, runExceptT)
import Data.Aeson import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint) import Data.Char (chr, isPrint)
import Data.Foldable (forM_) import Data.Foldable (forM_)
import Data.Monoid hiding (getLast) import Data.Monoid hiding (getLast)
import Data.Proxy import Data.Proxy
import qualified Data.Text as T import qualified Data.Text as T
import GHC.Generics (Generic) import GHC.Generics (Generic)
import GHC.TypeLits
import qualified Network.HTTP.Client as C import qualified Network.HTTP.Client as C
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types (Status (..), badRequest400, import qualified Network.HTTP.Types as HTTP
methodGet, ok200, status400)
import Network.Socket import Network.Socket
import Network.Wai (Application, responseLBS) import Network.Wai (Request, requestHeaders, responseLBS)
import Network.Wai.Handler.Warp import Network.Wai.Handler.Warp
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Test.Hspec import Test.Hspec
@ -49,14 +54,22 @@ import Test.HUnit
import Test.QuickCheck import Test.QuickCheck
import Servant.API import Servant.API
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Client import Servant.Client
import Servant.Server import Servant.Server
import Servant.Server.Experimental.Auth
import qualified Servant.Common.Req as SCR
-- This declaration simply checks that all instances are in place.
_ = client comprehensiveAPI
spec :: Spec spec :: Spec
spec = describe "Servant.Client" $ do spec = describe "Servant.Client" $ do
sucessSpec sucessSpec
failSpec failSpec
wrappedApiSpec wrappedApiSpec
basicAuthSpec
genAuthSpec
-- * test data types -- * test data types
@ -92,6 +105,7 @@ type Api =
"get" :> Get '[JSON] Person "get" :> Get '[JSON] Person
:<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent :<|> "deleteEmpty" :> DeleteNoContent '[JSON] NoContent
:<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person :<|> "capture" :> Capture "name" String :> Get '[JSON,FormUrlEncoded] Person
:<|> "captureAll" :> CaptureAll "names" String :> Get '[JSON] [Person]
:<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person :<|> "body" :> ReqBody '[FormUrlEncoded,JSON] Person :> Post '[JSON] Person
:<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person
:<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person]
@ -109,11 +123,42 @@ type Api =
api :: Proxy Api api :: Proxy Api
api = Proxy api = Proxy
getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person
getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person
getCaptureAll :: [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
:<|> getCaptureAll
:<|> getBody
:<|> getQueryParam
:<|> getQueryParams
:<|> getQueryFlag
:<|> getRawSuccess
:<|> getRawFailure
:<|> getMultiple
:<|> getRespHeaders
:<|> getDeleteContentType = client api
server :: Application server :: Application
server = serve api ( server = serve api (
return alice return alice
:<|> return NoContent :<|> return NoContent
:<|> (\ name -> return $ Person name 0) :<|> (\ name -> return $ Person name 0)
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (\ name -> case name of :<|> (\ name -> case name of
Just "alice" -> return alice Just "alice" -> return alice
@ -121,8 +166,8 @@ server = serve api (
Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..])) :<|> (\ names -> return (zipWith Person names [0..]))
:<|> return :<|> return
:<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
:<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d)) :<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent :<|> return NoContent
@ -138,11 +183,57 @@ failApi = Proxy
failServer :: Application failServer :: Application
failServer = serve failApi ( failServer = serve failApi (
(\ _request respond -> respond $ responseLBS ok200 [] "") (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
:<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") :<|> (\_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 Request ()
genAuthHandler =
let handler req = case lookup "AuthHeader" (requestHeaders req) of
Nothing -> throwE (err401 { errBody = "Missing auth header" })
Just _ -> return ()
in mkAuthHandler handler
genAuthServerContext :: Context '[ AuthHandler Request () ]
genAuthServerContext = genAuthHandler :. EmptyContext
genAuthServer :: Application
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
{-# NOINLINE manager #-} {-# NOINLINE manager #-}
manager :: C.Manager manager :: C.Manager
manager = unsafePerformIO $ C.newManager C.defaultManagerSettings manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@ -151,76 +242,68 @@ sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do it "Servant.API.Get" $ \(_, baseUrl) -> do
let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
(left show <$> runExceptT getGet) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do it "allows empty content type" $ \(_, baseUrl) -> do
let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
(left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do it "allows content type" $ \(_, baseUrl) -> do
let getDeleteContentType = getLast $ client api baseUrl manager (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
(left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do it "Servant.API.Capture" $ \(_, baseUrl) -> do
let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
(left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.CaptureAll" $ \(_, baseUrl) -> do
let expected = [(Person "Paula" 0), (Person "Peta" 1)]
(left show <$> runExceptT (getCaptureAll ["Paula", "Peta"] manager baseUrl)) `shouldReturn` Right expected
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42 let p = Person "Clara" 42
getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
(left show <$> runExceptT (getBody p)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob")) responseStatus `shouldBe` HTTP.Status 400 "bob not found"
responseStatus `shouldBe` Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
(left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right [] (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
(left show <$> runExceptT (getQueryParams ["alice", "bob"]))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1] `shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $ context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
(left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
res <- runExceptT (getRawSuccess methodGet)
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do Right (code, body, ct, _, response) -> do
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream") (code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
C.responseBody response `shouldBe` body 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 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 HTTP.methodGet manager baseUrl)
res <- runExceptT (getRawFailure methodGet)
case res of case res of
Right _ -> assertFailure "expected Left, but got Right" Right _ -> assertFailure "expected Left, but got Right"
Left e -> do Left e -> do
Servant.Client.responseStatus e `shouldBe` status400 Servant.Client.responseStatus e `shouldBe` HTTP.status400
Servant.Client.responseBody e `shouldBe` "rawFailure" Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do it "Returns headers appropriately" $ \(_, baseUrl) -> do
let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager res <- runExceptT (getRespHeaders manager baseUrl)
res <- runExceptT getRespHeaders
case res of case res of
Left e -> assertFailure $ show e Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")] Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
modifyMaxSuccess (const 20) $ do modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do ioProperty $ do
result <- left show <$> runExceptT (getMultiple cap num flag body) result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
return $ return $
result === Right (cap, num, flag, body) result === Right (cap, num, flag, body)
@ -232,10 +315,10 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) = test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
let getResponse :: ExceptT ServantError IO () let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
getResponse = client api baseUrl manager getResponse = client api
Left FailureResponse{..} <- runExceptT getResponse Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
responseStatus `shouldBe` (Status 500 "error message") responseStatus `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $ in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") : (WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") : (WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
@ -248,45 +331,78 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- runExceptT getDeleteEmpty Left res <- runExceptT (getDeleteEmpty manager baseUrl)
case res of case res of
FailureResponse (Status 404 "Not Found") _ _ -> return () FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res _ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager let (_ :<|> _ :<|> getCapture :<|> _) = client api
Left res <- runExceptT (getCapture "foo") Left res <- runExceptT (getCapture "foo" manager baseUrl)
case res of case res of
DecodeFailure _ ("application/json") _ -> return () DecodeFailure _ ("application/json") _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res _ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager let (getGetWrongHost :<|> _) = client api
Left res <- runExceptT getGetWrongHost Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 ""))
case res of case res of
ConnectionError _ -> return () ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res _ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (getGet :<|> _ ) = client api baseUrl manager let (getGet :<|> _ ) = client api
Left res <- runExceptT getGet Left res <- runExceptT (getGet manager baseUrl)
case res of case res of
UnsupportedContentType ("application/octet-stream") _ -> return () UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res _ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager let (_ :<|> _ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
Left res <- runExceptT (getBody alice) Left res <- runExceptT (getBody alice manager baseUrl)
case res of case res of
InvalidContentTypeHeader "fooooo" _ -> return () InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer (api :: *), Server api ~ ExceptT ServantErr IO a, WrappedApi :: (HasServer (api :: *) '[], Server api ~ Handler a,
HasClient api, Client api ~ ExceptT ServantError IO ()) => HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi
basicAuthSpec :: Spec
basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ 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 = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ 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")
-- * utils -- * utils
@ -317,25 +433,3 @@ pathGen = fmap NonEmpty path
filter (not . (`elem` ("?%[]/#;" :: String))) $ filter (not . (`elem` ("?%[]/#;" :: String))) $
filter isPrint $ filter isPrint $
map chr [0..127] map chr [0..127]
class GetNth (n :: Nat) a b | n a -> b where
getNth :: Proxy n -> a -> b
instance OVERLAPPING_
GetNth 0 (x :<|> y) x where
getNth _ (x :<|> _) = x
instance OVERLAPPING_
(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 OVERLAPPING_
(GetLast b c) => GetLast (a :<|> b) c where
getLast (_ :<|> b) = getLast b
instance OVERLAPPING_
GetLast a a where
getLast a = a

1
servant-docs/.ghci Normal file
View file

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

13
servant-docs/CHANGELOG.md
View file

@ -1,4 +1,14 @@
HEAD 0.7.1
-----
* Support GHC 8.0
0.7
---
* Use `throwError` instead of `throwE` in documentation
0.5
---- ----
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
@ -9,6 +19,7 @@ HEAD
* Move `toSample` out of `ToSample` class * Move `toSample` out of `ToSample` class
* Add a few helper functions to define `toSamples` * Add a few helper functions to define `toSamples`
* Remove matrix params. * Remove matrix params.
* Added support for Basic authentication
0.4 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. All rights reserved.

4
servant-docs/example/greet.hs
View file

@ -81,7 +81,7 @@ type TestApi =
:<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet) :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] (Headers '[Header "X-Example" Int] Greet)
-- DELETE /greet/:greetid -- DELETE /greet/:greetid
:<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] () :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent
testApi :: Proxy TestApi testApi :: Proxy TestApi
testApi = Proxy testApi = Proxy
@ -91,7 +91,7 @@ testApi = Proxy
-- notes. -- notes.
extra :: ExtraInfo TestApi extra :: ExtraInfo TestApi
extra = extra =
extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] ())) $ extraInfo (Proxy :: Proxy ("greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent)) $
defAction & headers <>~ ["unicorns"] defAction & headers <>~ ["unicorns"]
& notes <>~ [ DocNote "Title" ["This is some text"] & notes <>~ [ DocNote "Title" ["This is some text"]
, DocNote "Second secton" ["And some more"] , DocNote "Second secton" ["And some more"]

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

@ -1,5 +1,5 @@
name: servant-docs name: servant-docs
version: 0.5 version: 0.8
synopsis: generate API docs for your servant webservice synopsis: generate API docs for your servant webservice
description: description:
Library for generating API docs from a servant API definition. Library for generating API docs from a servant API definition.
@ -9,14 +9,14 @@ description:
<https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG> <https://github.com/haskell-servant/servant/blob/master/servant-docs/CHANGELOG.md CHANGELOG>
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Alp Mestanogullari, Sönke Hahn, Julian K. Arni author: Servant Contributors
maintainer: alpmestan@gmail.com maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014-2015 Zalora South East Asia Pte Ltd copyright: 2014-2016 Zalora South East Asia Pte Ltd, Servant Contributors
category: Web category: Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
tested-with: GHC >= 7.8 tested-with: GHC >= 7.8
homepage: http://haskell-servant.github.io/ homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:
include/*.h include/*.h
@ -42,7 +42,7 @@ library
, http-media >= 0.6 , http-media >= 0.6
, http-types >= 0.7 , http-types >= 0.7
, lens , lens
, servant == 0.5.* , servant == 0.8.*
, string-conversions , string-conversions
, text , text
, unordered-containers , unordered-containers
@ -50,6 +50,8 @@ library
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include include-dirs: include
executable greet-docs executable greet-docs
@ -82,4 +84,3 @@ test-suite spec
, servant-docs , servant-docs
, string-conversions , string-conversions
default-language: Haskell2010 default-language: Haskell2010

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

@ -22,11 +22,12 @@ module Servant.Docs.Internal where
import Control.Applicative import Control.Applicative
import Control.Arrow (second) 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 qualified Control.Monad.Omega as Omega
import Data.ByteString.Conversion (ToByteString, toByteString) import Data.ByteString.Conversion (ToByteString, toByteString)
import Data.ByteString.Lazy.Char8 (ByteString) import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.Hashable (Hashable) import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
@ -139,6 +140,12 @@ data DocIntro = DocIntro
, _introBody :: [String] -- ^ Each String is a paragraph. , _introBody :: [String] -- ^ Each String is a paragraph.
} deriving (Eq, Show) } 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 instance Ord DocIntro where
compare = comparing _introTitle compare = comparing _introTitle
@ -156,7 +163,7 @@ data DocNote = DocNote
-- --
-- These are intended to be built using extraInfo. -- These are intended to be built using extraInfo.
-- Multiple ExtraInfo may be combined with the monoid instance. -- Multiple ExtraInfo may be combined with the monoid instance.
newtype ExtraInfo layout = ExtraInfo (HashMap Endpoint Action) newtype ExtraInfo api = ExtraInfo (HashMap Endpoint Action)
instance Monoid (ExtraInfo a) where instance Monoid (ExtraInfo a) where
mempty = ExtraInfo mempty mempty = ExtraInfo mempty
ExtraInfo a `mappend` ExtraInfo b = ExtraInfo a `mappend` ExtraInfo b =
@ -229,7 +236,8 @@ defResponse = Response
-- You can tweak an 'Action' (like the default 'defAction') with these lenses -- You can tweak an 'Action' (like the default 'defAction') with these lenses
-- to transform an action and add some information to it. -- to transform an action and add some information to it.
data Action = Action 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 , _headers :: [Text] -- type collected
, _params :: [DocQueryParam] -- type collected + user supplied info , _params :: [DocQueryParam] -- type collected + user supplied info
, _notes :: [DocNote] -- user supplied , _notes :: [DocNote] -- user supplied
@ -246,8 +254,8 @@ data Action = Action
-- 'combineAction' to mush two together taking the response, body and content -- 'combineAction' to mush two together taking the response, body and content
-- types from the very left. -- types from the very left.
combineAction :: Action -> Action -> Action combineAction :: Action -> Action -> Action
Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ = Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp 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 -- Default 'Action'. Has no 'captures', no GET 'params', expects
-- no request body ('rqbody') and the typical response is 'defResponse'. -- no request body ('rqbody') and the typical response is 'defResponse'.
@ -267,6 +275,7 @@ defAction =
[] []
[] []
[] []
[]
defResponse defResponse
-- | Create an API that's comprised of a single endpoint. -- | Create an API that's comprised of a single endpoint.
@ -276,6 +285,7 @@ single :: Endpoint -> Action -> API
single e a = API mempty (HM.singleton e a) single e a = API mempty (HM.singleton e a)
-- gimme some lenses -- gimme some lenses
makeLenses ''DocAuthentication
makeLenses ''DocOptions makeLenses ''DocOptions
makeLenses ''API makeLenses ''API
makeLenses ''Endpoint makeLenses ''Endpoint
@ -290,11 +300,11 @@ makeLenses ''Action
-- default way to create documentation. -- default way to create documentation.
-- --
-- prop> docs == docsWithOptions defaultDocOptions -- prop> docs == docsWithOptions defaultDocOptions
docs :: HasDocs layout => Proxy layout -> API docs :: HasDocs api => Proxy api -> API
docs p = docsWithOptions p defaultDocOptions docs p = docsWithOptions p defaultDocOptions
-- | Generate the docs for a given API that implements 'HasDocs'. -- | Generate the docs for a given API that implements 'HasDocs'.
docsWithOptions :: HasDocs layout => Proxy layout -> DocOptions -> API docsWithOptions :: HasDocs api => Proxy api -> DocOptions -> API
docsWithOptions p = docsFor p (defEndpoint, defAction) docsWithOptions p = docsFor p (defEndpoint, defAction)
-- | Closed type family, check if endpoint is exactly within API. -- | Closed type family, check if endpoint is exactly within API.
@ -306,7 +316,7 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
IsIn (e :> sa) (e :> sb) = IsIn sa sb IsIn (e :> sa) (e :> sb) = IsIn sa sb
IsIn e e = () IsIn e e = ()
-- | Create an 'ExtraInfo' that is garunteed to be within the given API layout. -- | Create an 'ExtraInfo' that is guaranteed to be within the given API layout.
-- --
-- The safety here is to ensure that you only add custom documentation to an -- The safety here is to ensure that you only add custom documentation to an
-- endpoint that actually exists within your API. -- endpoint that actually exists within your API.
@ -319,8 +329,8 @@ type family IsIn (endpoint :: *) (api :: *) :: Constraint where
-- > , DocNote "Second secton" ["And some more"] -- > , DocNote "Second secton" ["And some more"]
-- > ] -- > ]
extraInfo :: (IsIn endpoint layout, HasLink endpoint, HasDocs endpoint) extraInfo :: (IsIn endpoint api, HasLink endpoint, HasDocs endpoint)
=> Proxy endpoint -> Action -> ExtraInfo layout => Proxy endpoint -> Action -> ExtraInfo api
extraInfo p action = extraInfo p action =
let api = docsFor p (defEndpoint, defAction) defaultDocOptions let api = docsFor p (defEndpoint, defAction) defaultDocOptions
-- Assume one endpoint, HasLink constraint means that we should only ever -- Assume one endpoint, HasLink constraint means that we should only ever
@ -339,7 +349,7 @@ extraInfo p action =
-- 'extraInfo'. -- 'extraInfo'.
-- --
-- If you only want to add an introduction, use 'docsWithIntros'. -- If you only want to add an introduction, use 'docsWithIntros'.
docsWith :: HasDocs layout => DocOptions -> [DocIntro] -> ExtraInfo layout -> Proxy layout -> API docsWith :: HasDocs api => DocOptions -> [DocIntro] -> ExtraInfo api -> Proxy api -> API
docsWith opts intros (ExtraInfo endpoints) p = docsWith opts intros (ExtraInfo endpoints) p =
docsWithOptions p opts docsWithOptions p opts
& apiIntros <>~ intros & apiIntros <>~ intros
@ -348,13 +358,13 @@ docsWith opts intros (ExtraInfo endpoints) p =
-- | Generate the docs for a given API that implements 'HasDocs' with with any -- | Generate the docs for a given API that implements 'HasDocs' with with any
-- number of introduction(s) -- number of introduction(s)
docsWithIntros :: HasDocs layout => [DocIntro] -> Proxy layout -> API docsWithIntros :: HasDocs api => [DocIntro] -> Proxy api -> API
docsWithIntros intros = docsWith defaultDocOptions intros mempty docsWithIntros intros = docsWith defaultDocOptions intros mempty
-- | The class that abstracts away the impact of API combinators -- | The class that abstracts away the impact of API combinators
-- on documentation generation. -- on documentation generation.
class HasDocs layout where class HasDocs api where
docsFor :: Proxy layout -> (Endpoint, Action) -> DocOptions -> API docsFor :: Proxy api -> (Endpoint, Action) -> DocOptions -> API
-- | The class that lets us display a sample input or output in the supported -- | The class that lets us display a sample input or output in the supported
-- content-types when generating documentation for endpoints that either: -- content-types when generating documentation for endpoints that either:
@ -453,7 +463,7 @@ instance AllHeaderSamples '[] where
instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h) instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
=> AllHeaderSamples (Header h l ': ls) where => AllHeaderSamples (Header h l ': ls) where
allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) : allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
allHeaderToSample (Proxy :: Proxy ls) allHeaderToSample (Proxy :: Proxy ls)
where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h) where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
mkHeader (Just x) = (headerName, cs $ toByteString x) mkHeader (Just x) = (headerName, cs $ toByteString x)
@ -503,6 +513,10 @@ class ToParam t where
class ToCapture c where class ToCapture c where
toCapture :: Proxy c -> DocCapture 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 -- | Generate documentation in Markdown format for
-- the given 'API'. -- the given 'API'.
markdown :: API -> String markdown :: API -> String
@ -515,6 +529,7 @@ markdown api = unlines $
str : str :
"" : "" :
notesStr (action ^. notes) ++ notesStr (action ^. notes) ++
authStr (action ^. authInfo) ++
capturesStr (action ^. captures) ++ capturesStr (action ^. captures) ++
headersStr (action ^. headers) ++ headersStr (action ^. headers) ++
paramsStr (action ^. params) ++ paramsStr (action ^. params) ++
@ -522,7 +537,7 @@ markdown api = unlines $
responseStr (action ^. response) ++ responseStr (action ^. response) ++
[] []
where str = "## " ++ show (endpoint^.method) where str = "## " ++ BSC.unpack (endpoint^.method)
++ " " ++ showPath (endpoint^.path) ++ " " ++ showPath (endpoint^.path)
introsStr :: [DocIntro] -> [String] introsStr :: [DocIntro] -> [String]
@ -547,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 :: [DocCapture] -> [String]
capturesStr [] = [] capturesStr [] = []
capturesStr l = capturesStr l =
@ -646,27 +675,43 @@ markdown api = unlines $
-- | The generated docs for @a ':<|>' b@ just appends the docs -- | The generated docs for @a ':<|>' b@ just appends the docs
-- for @a@ with the docs for @b@. -- for @a@ with the docs for @b@.
instance OVERLAPPABLE_ instance OVERLAPPABLE_
(HasDocs layout1, HasDocs layout2) (HasDocs a, HasDocs b)
=> HasDocs (layout1 :<|> layout2) where => HasDocs (a :<|> b) where
docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action) docsFor Proxy (ep, action) = docsFor p1 (ep, action) <> docsFor p2 (ep, action)
where p1 :: Proxy layout1 where p1 :: Proxy a
p1 = Proxy p1 = Proxy
p2 :: Proxy layout2 p2 :: Proxy b
p2 = Proxy p2 = Proxy
-- | @"books" :> 'Capture' "isbn" Text@ will appear as -- | @"books" :> 'Capture' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs. -- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs sublayout) instance (KnownSymbol sym, ToCapture (Capture sym a), HasDocs api)
=> HasDocs (Capture sym a :> sublayout) where => HasDocs (Capture sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint', action')
where subApiP = Proxy :: Proxy api
captureP = Proxy :: Proxy (Capture sym a)
action' = over captures (|> toCapture captureP) action
endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
symP = Proxy :: Proxy sym
-- | @"books" :> 'CaptureAll' "isbn" Text@ will appear as
-- @/books/:isbn@ in the docs.
instance (KnownSymbol sym, ToCapture (CaptureAll sym a), HasDocs sublayout)
=> HasDocs (CaptureAll sym a :> sublayout) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint', action') docsFor sublayoutP (endpoint', action')
where sublayoutP = Proxy :: Proxy sublayout where sublayoutP = Proxy :: Proxy sublayout
captureP = Proxy :: Proxy (Capture sym a) captureP = Proxy :: Proxy (CaptureAll sym a)
action' = over captures (|> toCapture captureP) action action' = over captures (|> toCapture captureP) action
endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint endpoint' = over path (\p -> p ++ [":" ++ symbolVal symP]) endpoint
@ -707,34 +752,43 @@ instance OVERLAPPING_
status = fromInteger $ natVal (Proxy :: Proxy status) status = fromInteger $ natVal (Proxy :: Proxy status)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs sublayout) instance (KnownSymbol sym, HasDocs api)
=> HasDocs (QueryParam sym a :> sublayout) where => HasDocs (Header sym a :> api) where
docsFor Proxy (endpoint, action) =
docsFor subApiP (endpoint, action')
where subApiP = Proxy :: Proxy api
action' = over headers (|> headername) action
headername = T.pack $ symbolVal (Proxy :: Proxy sym)
instance (KnownSymbol sym, ToParam (QueryParam sym a), HasDocs api)
=> HasDocs (QueryParam sym a :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action') docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryParam sym a) paramP = Proxy :: Proxy (QueryParam sym a)
action' = over params (|> toParam paramP) action action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryParams sym a), HasDocs api)
=> HasDocs (QueryParams sym a :> sublayout) where => HasDocs (QueryParams sym a :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action') docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryParams sym a) paramP = Proxy :: Proxy (QueryParams sym a)
action' = over params (|> toParam paramP) action action' = over params (|> toParam paramP) action
instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs sublayout) instance (KnownSymbol sym, ToParam (QueryFlag sym), HasDocs api)
=> HasDocs (QueryFlag sym :> sublayout) where => HasDocs (QueryFlag sym :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action') docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout where subApiP = Proxy :: Proxy api
paramP = Proxy :: Proxy (QueryFlag sym) paramP = Proxy :: Proxy (QueryFlag sym)
action' = over params (|> toParam paramP) action action' = over params (|> toParam paramP) action
@ -747,45 +801,55 @@ instance HasDocs Raw where
-- example data. However, there's no reason to believe that the instances of -- example data. However, there's no reason to believe that the instances of
-- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that -- 'AllMimeUnrender' and 'AllMimeRender' actually agree (or to suppose that
-- both are even defined) for any particular type. -- both are even defined) for any particular type.
instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs sublayout) instance (ToSample a, AllMimeRender (ct ': cts) a, HasDocs api)
=> HasDocs (ReqBody (ct ': cts) a :> sublayout) where => HasDocs (ReqBody (ct ': cts) a :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint, action') docsFor subApiP (endpoint, action')
where sublayoutP = Proxy :: Proxy sublayout where subApiP = Proxy :: Proxy api
action' = action & rqbody .~ sampleByteString t p action' = action & rqbody .~ sampleByteString t p
& rqtypes .~ allMime t & rqtypes .~ allMime t
t = Proxy :: Proxy (ct ': cts) t = Proxy :: Proxy (ct ': cts)
p = Proxy :: Proxy a p = Proxy :: Proxy a
instance (KnownSymbol path, HasDocs sublayout) => HasDocs (path :> sublayout) where instance (KnownSymbol path, HasDocs api) => HasDocs (path :> api) where
docsFor Proxy (endpoint, action) = docsFor Proxy (endpoint, action) =
docsFor sublayoutP (endpoint', action) docsFor subApiP (endpoint', action)
where sublayoutP = Proxy :: Proxy sublayout where subApiP = Proxy :: Proxy api
endpoint' = endpoint & path <>~ [symbolVal pa] endpoint' = endpoint & path <>~ [symbolVal pa]
pa = Proxy :: Proxy path pa = Proxy :: Proxy path
instance HasDocs sublayout => HasDocs (RemoteHost :> sublayout) where instance HasDocs api => HasDocs (RemoteHost :> api) where
docsFor Proxy ep = docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (IsSecure :> sublayout) where instance HasDocs api => HasDocs (IsSecure :> api) where
docsFor Proxy ep = docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (HttpVersion :> sublayout) where instance HasDocs api => HasDocs (HttpVersion :> api) where
docsFor Proxy ep = docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep docsFor (Proxy :: Proxy api) ep
instance HasDocs sublayout => HasDocs (Vault :> sublayout) where instance HasDocs api => HasDocs (Vault :> api) where
docsFor Proxy ep = docsFor Proxy ep =
docsFor (Proxy :: Proxy sublayout) ep docsFor (Proxy :: Proxy api) ep
instance HasDocs api => HasDocs (WithNamedContext name context api) where
docsFor Proxy = docsFor (Proxy :: Proxy api)
instance (ToAuthInfo (BasicAuth realm usr), HasDocs api) => HasDocs (BasicAuth realm usr :> api) where
docsFor Proxy (endpoint, action) =
docsFor (Proxy :: Proxy api) (endpoint, action')
where
authProxy = Proxy :: Proxy (BasicAuth realm usr)
action' = over authInfo (|> toAuthInfo authProxy) action
-- ToSample instances for simple types -- ToSample instances for simple types
instance ToSample () instance ToSample NoContent
instance ToSample Bool instance ToSample Bool
instance ToSample Ordering instance ToSample Ordering

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

@ -29,12 +29,12 @@ instance ToJSON a => MimeRender PrettyJSON a where
-- @ -- @
-- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI)) -- 'docs' ('pretty' ('Proxy' :: 'Proxy' MyAPI))
-- @ -- @
pretty :: Proxy layout -> Proxy (Pretty layout) pretty :: Proxy api -> Proxy (Pretty api)
pretty Proxy = Proxy pretty Proxy = Proxy
-- | Replace all JSON content types with PrettyJSON. -- | Replace all JSON content types with PrettyJSON.
-- Kind-polymorphic so it can operate on kinds @*@ and @[*]@. -- Kind-polymorphic so it can operate on kinds @*@ and @[*]@.
type family Pretty (layout :: k) :: k where type family Pretty (api :: k) :: k where
Pretty (x :<|> y) = Pretty x :<|> Pretty y Pretty (x :<|> y) = Pretty x :<|> Pretty y
Pretty (x :> y) = Pretty x :> Pretty y Pretty (x :> y) = Pretty x :> Pretty y
Pretty (Get cs r) = Get (Pretty cs) r Pretty (Get cs r) = Get (Pretty cs) r

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

@ -1,7 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
@ -18,8 +18,27 @@ import GHC.Generics
import Test.Hspec import Test.Hspec
import Servant.API import Servant.API
import Servant.API.Internal.Test.ComprehensiveAPI
import Servant.Docs.Internal 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"
instance ToCapture (CaptureAll "foo" Int) where
toCapture = error "unused"
-- * specs
spec :: Spec spec :: Spec
spec = describe "Servant.Docs" $ do spec = describe "Servant.Docs" $ do
@ -63,6 +82,7 @@ spec = describe "Servant.Docs" $ do
, ("zwei, kaks, kaks",(TT2,UT2,UT2)) , ("zwei, kaks, kaks",(TT2,UT2,UT2))
] ]
where where
tests md = do tests md = do
it "mentions supported content-types" $ do it "mentions supported content-types" $ do
@ -72,15 +92,19 @@ spec = describe "Servant.Docs" $ do
it "mentions status codes" $ do it "mentions status codes" $ do
md `shouldContain` "Status code 200" md `shouldContain` "Status code 200"
it "mentions methods" $ do it "has methods as section headers" $ do
md `shouldContain` "POST" md `shouldContain` "## POST"
md `shouldContain` "GET" 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" $ it "contains response samples" $
md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}" md `shouldContain` "{\"dt1field1\":\"field 1\",\"dt1field2\":13}"
it "contains request body samples" $ it "contains request body samples" $
md `shouldContain` "17" md `shouldContain` "17"
-- * APIs -- * APIs
data Datatype1 = Datatype1 { dt1field1 :: String data Datatype1 = Datatype1 { dt1field1 :: String
@ -103,6 +127,7 @@ instance MimeRender PlainText Int where
type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
:<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1 :<|> ReqBody '[JSON] String :> Post '[JSON] Datatype1
:<|> Header "X-Test" Int :> Put '[JSON] Int
data TT = TT1 | TT2 deriving (Show, Eq) data TT = TT1 | TT2 deriving (Show, Eq)
data UT = UT1 | UT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq)

30
servant-examples/LICENSE
View file

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

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

8
servant-examples/include/overlapping-compat.h
View file

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

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

8
servant-foreign/CHANGELOG.md
View file

@ -1,4 +1,10 @@
HEAD 0.7.1
-----
* Support GHC 8.0
0.5
----- -----
* Use the `text` package instead of `String`. * Use the `text` package instead of `String`.
* Extract javascript-oblivious types and helpers to *servant-foreign* * 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. All rights reserved.

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

@ -1,5 +1,5 @@
name: servant-foreign name: servant-foreign
version: 0.5 version: 0.8
synopsis: Helpers for generating clients for servant APIs in any programming language synopsis: Helpers for generating clients for servant APIs in any programming language
description: description:
Helper types and functions for generating client functions for servant APIs in any programming language Helper types and functions for generating client functions for servant APIs in any programming language
@ -11,9 +11,9 @@ description:
<https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG> <https://github.com/haskell-servant/servant/blob/master/servant-foreign/CHANGELOG.md CHANGELOG>
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Denis Redozubov, Maksymilian Owsianny author: Servant Contributors
maintainer: denis.redozubov@gmail.com maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2015 Denis Redozubov, Alp Mestanogullari copyright: 2015-2016 Servant Contributors
category: Web category: Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
@ -21,21 +21,41 @@ extra-source-files:
include/*.h include/*.h
CHANGELOG.md CHANGELOG.md
README.md README.md
bug-reports: http://github.com/haskell-servant/servant/issues
source-repository head source-repository head
type: git type: git
location: http://github.com/haskell-servant/servant.git location: http://github.com/haskell-servant/servant.git
library library
exposed-modules: Servant.Foreign, Servant.Foreign.Internal exposed-modules: Servant.Foreign
, Servant.Foreign.Internal
, Servant.Foreign.Inflections
build-depends: base == 4.* build-depends: base == 4.*
, lens == 4.* , lens == 4.*
, servant == 0.5.* , servant == 0.8.*
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, http-types , http-types
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall
if impl(ghc >= 8.0)
ghc-options: -Wno-redundant-constraints
include-dirs: include include-dirs: include
default-extensions: CPP
, ConstraintKinds
, DataKinds
, FlexibleContexts
, FlexibleInstances
, GeneralizedNewtypeDeriving
, MultiParamTypeClasses
, ScopedTypeVariables
, StandaloneDeriving
, TemplateHaskell
, TypeFamilies
, TypeOperators
, UndecidableInstances
, OverloadedStrings
, PolyKinds
test-suite spec test-suite spec
@ -44,9 +64,20 @@ test-suite spec
ghc-options: -Wall ghc-options: -Wall
include-dirs: include include-dirs: include
main-is: Spec.hs main-is: Spec.hs
other-modules: other-modules: Servant.ForeignSpec
Servant.ForeignSpec
build-depends: base build-depends: base
, hspec >= 2.1.8 , hspec >= 2.1.8
, servant-foreign , servant-foreign
default-language: Haskell2010 default-language: Haskell2010
default-extensions: ConstraintKinds
, DataKinds
, FlexibleContexts
, FlexibleInstances
, GeneralizedNewtypeDeriving
, MultiParamTypeClasses
, ScopedTypeVariables
, TypeFamilies
, TypeOperators
, UndecidableInstances
, OverloadedStrings
, PolyKinds

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

@ -1,39 +1,56 @@
-- | Generalizes all the data needed to make code generation work with -- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages. -- arbitrary programming languages.
module Servant.Foreign module Servant.Foreign
( HasForeign(..) ( ArgType(..)
, HasForeignType(..) , HeaderArg(..)
, QueryArg(..)
, Req(..)
, Segment(..) , Segment(..)
, SegmentType(..) , SegmentType(..)
, FunctionName , Url(..)
, QueryArg(..) -- aliases
, HeaderArg(..) , Path
, ArgType(..) , Arg(..)
, Req , FunctionName(..)
, captureArg , PathSegment(..)
, defReq -- lenses
, concatCase
, snakeCase
, camelCase
-- lenses
, argType
, argName , argName
, isCapture , argType
, funcName , argPath
, path
, reqUrl , reqUrl
, reqBody
, reqHeaders
, reqMethod , reqMethod
, reqHeaders
, reqBody
, reqReturnType , reqReturnType
, segment , reqFuncName
, path
, queryStr , queryStr
, listFromAPI , queryArgName
, queryArgType
, headerArg
-- prisms
, _PathSegment
, _HeaderArg
, _ReplaceHeaderArg
, _Static
, _Cap
, _Normal
, _Flag
, _List
-- rest of it
, HasForeign(..)
, HasForeignType(..)
, GenerateList(..) , GenerateList(..)
, NoTypes , NoTypes
-- re-exports , captureArg
, isCapture
, defReq
, listFromAPI
-- re-exports
, module Servant.API , module Servant.API
, module Servant.Foreign.Inflections
) where ) where
import Servant.API import Servant.API
import Servant.Foreign.Internal 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

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

@ -1,119 +1,139 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE NullaryTypeClasses #-} {-# LANGUAGE NullaryTypeClasses #-}
#endif #endif
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
-- | Generalizes all the data needed to make code generation work with -- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages. -- arbitrary programming languages.
module Servant.Foreign.Internal where module Servant.Foreign.Internal where
import Control.Lens (makeLenses, (%~), (&), (.~), (<>~)) import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
import qualified Data.Char as C (.~))
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
import Data.Proxy import Data.Proxy
import Data.String
import Data.Text import Data.Text
import Data.Text.Encoding (decodeUtf8) import Data.Text.Encoding (decodeUtf8)
import GHC.Exts (Constraint) import GHC.Exts (Constraint)
import GHC.TypeLits import GHC.TypeLits
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import Prelude hiding (concat) import Prelude hiding (concat)
import Servant.API 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. newtype FunctionName = FunctionName { unFunctionName :: [Text] }
-- each part is separated by a single underscore character. deriving (Show, Eq, Monoid)
snakeCase :: FunctionName -> Text
snakeCase = intercalate "_"
-- | Function name builder using the CamelCase convention. makePrisms ''FunctionName
-- 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
type ForeignType = Text newtype PathSegment = PathSegment { unPathSegment :: Text }
type Arg = (Text, ForeignType) deriving (Show, Eq, IsString, Monoid)
newtype Segment = Segment { _segment :: SegmentType } makePrisms ''PathSegment
deriving (Eq, Show)
data SegmentType = Static Text -- ^ a static path segment. like "/foo" data Arg f = Arg
| Cap Arg -- ^ a capture. like "/:userid" { _argName :: PathSegment
deriving (Eq, Show) , _argType :: f }
type Path = [Segment] deriving instance Eq f => Eq (Arg f)
deriving instance Show f => Show (Arg f)
data ArgType = makeLenses ''Arg
Normal
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 | Flag
| List | List
deriving (Eq, Show) deriving (Eq, Show)
data QueryArg = QueryArg makePrisms ''ArgType
{ _argName :: Arg
, _argType :: ArgType
} deriving (Eq, Show)
data HeaderArg = HeaderArg data QueryArg f = QueryArg
{ headerArg :: Arg { _queryArgName :: Arg f
} , _queryArgType :: ArgType
| ReplaceHeaderArg }
{ headerArg :: Arg
, headerPattern :: Text
} deriving (Eq, Show)
deriving instance Eq f => Eq (QueryArg f)
data Url = Url deriving instance Show f => Show (QueryArg f)
{ _path :: Path
, _queryStr :: [QueryArg]
} deriving (Eq, Show)
defUrl :: Url
defUrl = Url [] []
type FunctionName = [Text]
data Req = Req
{ _reqUrl :: Url
, _reqMethod :: HTTP.Method
, _reqHeaders :: [HeaderArg]
, _reqBody :: Maybe ForeignType
, _reqReturnType :: ForeignType
, _funcName :: FunctionName
} deriving (Eq, Show)
makeLenses ''QueryArg 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 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 makeLenses ''Req
isCapture :: Segment -> Bool defReq :: Req ftype
isCapture (Segment (Cap _)) = True defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName [])
isCapture _ = False
captureArg :: Segment -> Arg
captureArg (Segment (Cap s)) = s
captureArg _ = error "captureArg called on non capture"
defReq :: Req
defReq = Req defUrl "GET" [] Nothing "" []
-- | To be used exclusively as a "negative" return type/constraint -- | To be used exclusively as a "negative" return type/constraint
-- by @'Elem`@ type family. -- by @'Elem`@ type family.
@ -126,194 +146,233 @@ type family Elem (a :: *) (ls::[*]) :: Constraint where
-- | 'HasForeignType' maps Haskell types with types in the target -- | 'HasForeignType' maps Haskell types with types in the target
-- language of your backend. For example, let's say you're -- 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 -- > -- First you need to create a dummy type to parametrize your
-- > -- instances. -- > -- instances.
-- > data LangX -- > data LangX
-- > -- >
-- > -- Otherwise you define instances for the types you need -- > -- Otherwise you define instances for the types you need
-- > instance HasForeignType LangX Int where -- > instance HasForeignType LangX Text Int where
-- > typeFor _ _ = "intX" -- > typeFor _ _ _ = "intX"
-- > -- >
-- > -- Or for example in case of lists -- > -- Or for example in case of lists
-- > instance HasForeignType LangX a => HasForeignType LangX [a] where -- > instance HasForeignType LangX Text a => HasForeignType LangX Text [a] where
-- > typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) -- > typeFor lang type _ = "listX of " <> typeFor lang ftype (Proxy :: Proxy a)
-- --
-- Finally to generate list of information about all the endpoints for -- Finally to generate list of information about all the endpoints for
-- an API you create a function of a form: -- an API you create a function of a form:
-- --
-- > getEndpoints :: (HasForeign LangX api, GenerateList (Foreign api)) -- > getEndpoints :: (HasForeign LangX Text api, GenerateList Text (Foreign Text api))
-- > => Proxy api -> [Req] -- > => Proxy api -> [Req Text]
-- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) api -- > getEndpoints api = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy Text) api
-- --
-- > -- If language __X__ is dynamically typed then you can use -- > -- If language __X__ is dynamically typed then you can use
-- > -- a predefined NoTypes parameter -- > -- a predefined NoTypes parameter with the NoContent output type:
-- > getEndpoints :: (HasForeign NoTypes api, GenerateList (Foreign api)) --
-- > => Proxy api -> [Req] -- > getEndpoints :: (HasForeign NoTypes NoContent api, GenerateList Text (Foreign NoContent api))
-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) api -- > => Proxy api -> [Req NoContent]
-- > getEndpoints api = listFromAPI (Proxy :: Proxy NoTypes) (Proxy :: Proxy NoContent) api
-- > -- >
-- --
class HasForeignType lang a where class HasForeignType lang ftype a where
typeFor :: Proxy lang -> Proxy a -> ForeignType typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype
data NoTypes data NoTypes
instance HasForeignType NoTypes a where instance HasForeignType NoTypes NoContent ftype where
typeFor _ _ = empty typeFor _ _ _ = NoContent
class HasForeign lang (layout :: *) where class HasForeign lang ftype (api :: *) where
type Foreign layout :: * type Foreign ftype api :: *
foreignFor :: Proxy lang -> Proxy layout -> Req -> Foreign layout foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api
instance (HasForeign lang a, HasForeign lang b) instance (HasForeign lang ftype a, HasForeign lang ftype b)
=> HasForeign lang (a :<|> b) where => HasForeign lang ftype (a :<|> b) where
type Foreign (a :<|> b) = Foreign a :<|> Foreign b type Foreign ftype (a :<|> b) = Foreign ftype a :<|> Foreign ftype b
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy a) req foreignFor lang ftype (Proxy :: Proxy a) req
:<|> foreignFor lang (Proxy :: Proxy b) req :<|> foreignFor lang ftype (Proxy :: Proxy b) req
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) instance (KnownSymbol sym, HasForeignType lang ftype t, HasForeign lang ftype api)
=> HasForeign lang (Capture sym a :> sublayout) where => HasForeign lang ftype (Capture sym t :> api) where
type Foreign (Capture sym a :> sublayout) = Foreign sublayout type Foreign ftype (Capture sym a :> api) = Foreign ftype api
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.path <>~ [Segment (Cap arg)]
& funcName %~ (++ ["by", str])
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy (Proxy :: Proxy api) $
req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str])
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) 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, ReflectMethod method) instance (KnownSymbol sym, HasForeignType lang ftype [t], HasForeign lang ftype sublayout)
=> HasForeign lang (Verb method status list a) where => HasForeign lang ftype (CaptureAll sym t :> sublayout) where
type Foreign (Verb method status list a) = Req type Foreign ftype (CaptureAll sym t :> sublayout) = Foreign ftype sublayout
foreignFor lang Proxy req = foreignFor lang Proxy Proxy req =
req & funcName %~ (methodLC :) foreignFor lang Proxy (Proxy :: Proxy sublayout) $
req & reqUrl . path <>~ [Segment (Cap arg)]
& reqFuncName . _FunctionName %~ (++ ["by", str])
where
str = pack . symbolVal $ (Proxy :: Proxy sym)
ftype = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy [t])
arg = Arg
{ _argName = PathSegment str
, _argType = ftype }
instance (Elem JSON list, HasForeignType lang 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 Proxy req =
req & reqFuncName . _FunctionName %~ (methodLC :)
& reqMethod .~ method & reqMethod .~ method
& reqReturnType .~ retType & reqReturnType .~ Just retType
where where
retType = typeFor lang (Proxy :: Proxy a) retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a)
method = reflectMethod (Proxy :: Proxy method) method = reflectMethod (Proxy :: Proxy method)
methodLC = toLower $ decodeUtf8 method methodLC = toLower $ decodeUtf8 method
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang (Header sym a :> sublayout) where => HasForeign lang ftype (Header sym a :> api) where
type Foreign (Header sym a :> sublayout) = Foreign sublayout type Foreign ftype (Header sym a :> api) = Foreign ftype api
foreignFor lang Proxy req =
foreignFor lang subP $ req
& reqHeaders <>~ [HeaderArg arg]
foreignFor lang Proxy Proxy req =
foreignFor lang Proxy subP $ req & reqHeaders <>~ [HeaderArg arg]
where where
hname = pack . symbolVal $ (Proxy :: Proxy sym) hname = pack . symbolVal $ (Proxy :: Proxy sym)
arg = (hname, typeFor lang (Proxy :: Proxy a)) arg = Arg
subP = Proxy :: Proxy sublayout { _argName = PathSegment hname
, _argType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a) }
subP = Proxy :: Proxy api
instance (KnownSymbol sym, HasForeignType lang a, HasForeign lang sublayout) instance (KnownSymbol sym, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang (QueryParam sym a :> sublayout) where => HasForeign lang ftype (QueryParam sym a :> api) where
type Foreign (QueryParam sym a :> sublayout) = Foreign sublayout type Foreign ftype (QueryParam sym a :> api) = Foreign ftype api
foreignFor lang Proxy req = foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
req & reqUrl.queryStr <>~ [QueryArg arg Normal] req & reqUrl.queryStr <>~ [QueryArg arg Normal]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) 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) instance
=> HasForeign lang (QueryParams sym a :> sublayout) where (KnownSymbol sym, HasForeignType lang ftype [a], HasForeign lang ftype api)
type Foreign (QueryParams sym a :> sublayout) = Foreign sublayout => HasForeign lang ftype (QueryParams sym a :> api) where
type Foreign ftype (QueryParams sym a :> api) = Foreign ftype api
foreignFor lang Proxy req = foreignFor lang Proxy Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy api) $
req & reqUrl.queryStr <>~ [QueryArg arg List] req & reqUrl.queryStr <>~ [QueryArg arg List]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) 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) instance
=> HasForeign lang (QueryFlag sym :> sublayout) where (KnownSymbol sym, HasForeignType lang ftype Bool, HasForeign lang ftype api)
type Foreign (QueryFlag sym :> sublayout) = Foreign sublayout => HasForeign lang ftype (QueryFlag sym :> api) where
type Foreign ftype (QueryFlag sym :> api) = Foreign ftype api
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype (Proxy :: Proxy api) $
req & reqUrl.queryStr <>~ [QueryArg arg Flag] req & reqUrl.queryStr <>~ [QueryArg arg Flag]
where where
str = pack . symbolVal $ (Proxy :: Proxy sym) 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 instance HasForeign lang ftype Raw where
type Foreign Raw = HTTP.Method -> Req type Foreign ftype Raw = HTTP.Method -> Req ftype
foreignFor _ Proxy req method = foreignFor _ Proxy Proxy req method =
req & funcName %~ ((toLower $ decodeUtf8 method) :) req & reqFuncName . _FunctionName %~ ((toLower $ decodeUtf8 method) :)
& reqMethod .~ method & reqMethod .~ method
instance (Elem JSON list, HasForeignType lang a, HasForeign lang sublayout) instance (Elem JSON list, HasForeignType lang ftype a, HasForeign lang ftype api)
=> HasForeign lang (ReqBody list a :> sublayout) where => HasForeign lang ftype (ReqBody list a :> api) where
type Foreign (ReqBody list a :> sublayout) = Foreign sublayout type Foreign ftype (ReqBody list a :> api) = Foreign ftype api
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $ foreignFor lang ftype (Proxy :: Proxy api) $
req & reqBody .~ (Just $ typeFor lang (Proxy :: Proxy a)) req & reqBody .~ (Just $ typeFor lang ftype (Proxy :: Proxy a))
instance (KnownSymbol path, HasForeign lang sublayout) instance (KnownSymbol path, HasForeign lang ftype api)
=> HasForeign lang (path :> sublayout) where => HasForeign lang ftype (path :> api) where
type Foreign (path :> sublayout) = Foreign sublayout type Foreign ftype (path :> api) = Foreign ftype api
foreignFor lang Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) $
req & reqUrl.path <>~ [Segment (Static str)]
& funcName %~ (++ [str])
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy api) $
req & reqUrl . path <>~ [Segment (Static (PathSegment str))]
& reqFuncName . _FunctionName %~ (++ [str])
where where
str = Data.Text.map (\c -> if c == '.' then '_' else c) str =
. pack . symbolVal $ (Proxy :: Proxy path) Data.Text.map (\c -> if c == '.' then '_' else c)
. pack . symbolVal $ (Proxy :: Proxy path)
instance HasForeign lang sublayout => HasForeign lang (RemoteHost :> sublayout) where instance HasForeign lang ftype api
type Foreign (RemoteHost :> sublayout) = Foreign sublayout => HasForeign lang ftype (RemoteHost :> api) where
type Foreign ftype (RemoteHost :> api) = Foreign ftype api
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang sublayout => HasForeign lang (IsSecure :> sublayout) where instance HasForeign lang ftype api
type Foreign (IsSecure :> sublayout) = Foreign sublayout => HasForeign lang ftype (IsSecure :> api) where
type Foreign ftype (IsSecure :> api) = Foreign ftype api
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang sublayout => HasForeign lang (Vault :> sublayout) where instance HasForeign lang ftype api => HasForeign lang ftype (Vault :> api) where
type Foreign (Vault :> sublayout) = Foreign sublayout type Foreign ftype (Vault :> api) = Foreign ftype api
foreignFor lang Proxy req = foreignFor lang ftype Proxy req =
foreignFor lang (Proxy :: Proxy sublayout) req foreignFor lang ftype (Proxy :: Proxy api) req
instance HasForeign lang sublayout => HasForeign lang (HttpVersion :> sublayout) where instance HasForeign lang ftype api =>
type Foreign (HttpVersion :> sublayout) = Foreign sublayout HasForeign lang ftype (WithNamedContext name context api) where
foreignFor lang Proxy req = type Foreign ftype (WithNamedContext name context api) = Foreign ftype api
foreignFor lang (Proxy :: Proxy sublayout) req
foreignFor lang ftype Proxy = foreignFor lang ftype (Proxy :: Proxy api)
instance HasForeign lang ftype api
=> HasForeign lang ftype (HttpVersion :> api) where
type Foreign ftype (HttpVersion :> api) = Foreign ftype api
foreignFor lang ftype Proxy req =
foreignFor lang ftype (Proxy :: Proxy api) req
-- | Utility class used by 'listFromAPI' which computes -- | Utility class used by 'listFromAPI' which computes
-- the data needed to generate a function for each endpoint -- the data needed to generate a function for each endpoint
-- and hands it all back in a list. -- and hands it all back in a list.
class GenerateList reqs where class GenerateList ftype reqs where
generateList :: reqs -> [Req] generateList :: reqs -> [Req ftype]
instance GenerateList Req where instance GenerateList ftype (Req ftype) where
generateList r = [r] 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) generateList (start :<|> rest) = (generateList start) ++ (generateList rest)
-- | Generate the necessary data for codegen as a list, each 'Req' -- | Generate the necessary data for codegen as a list, each 'Req'
-- describing one endpoint from your API type. -- describing one endpoint from your API type.
listFromAPI :: (HasForeign lang api, GenerateList (Foreign api)) => Proxy lang -> Proxy api -> [Req] listFromAPI
listFromAPI lang p = generateList (foreignFor lang p defReq) :: (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)

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

@ -1,13 +1,4 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
#include "overlapping-compat.h" #include "overlapping-compat.h"
module Servant.ForeignSpec where module Servant.ForeignSpec where
@ -15,7 +6,6 @@ module Servant.ForeignSpec where
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Proxy import Data.Proxy
import Servant.Foreign import Servant.Foreign
import Servant.Foreign.Internal
import Test.Hspec import Test.Hspec
@ -27,87 +17,106 @@ spec = describe "Servant.Foreign" $ do
camelCaseSpec :: Spec camelCaseSpec :: Spec
camelCaseSpec = describe "camelCase" $ do camelCaseSpec = describe "camelCase" $ do
it "converts FunctionNames to camelCase" $ do it "converts FunctionNames to camelCase" $ do
camelCase ["post", "counter", "inc"] `shouldBe` "postCounterInc" camelCase (FunctionName ["post", "counter", "inc"])
camelCase ["get", "hyphen-ated", "counter"] `shouldBe` "getHyphenatedCounter" `shouldBe` "postCounterInc"
camelCase (FunctionName ["get", "hyphen-ated", "counter"])
`shouldBe` "getHyphenatedCounter"
---------------------------------------------------------------------- ----------------------------------------------------------------------
data LangX data LangX
instance HasForeignType LangX () where instance HasForeignType LangX String NoContent where
typeFor _ _ = "voidX" typeFor _ _ _ = "voidX"
instance HasForeignType LangX Int where
typeFor _ _ = "intX" instance HasForeignType LangX String Int where
instance HasForeignType LangX Bool where typeFor _ _ _ = "intX"
typeFor _ _ = "boolX"
instance OVERLAPPING_ HasForeignType LangX String where instance HasForeignType LangX String Bool where
typeFor _ _ = "stringX" typeFor _ _ _ = "boolX"
instance OVERLAPPABLE_ HasForeignType LangX a => HasForeignType LangX [a] where
typeFor lang _ = "listX of " <> typeFor lang (Proxy :: Proxy a) 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 type TestApi
= "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int = "test" :> Header "header" [String] :> QueryFlag "flag" :> Get '[JSON] Int
:<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] () :<|> "test" :> QueryParam "param" Int :> ReqBody '[JSON] [String] :> Post '[JSON] NoContent
:<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] () :<|> "test" :> QueryParams "params" Int :> ReqBody '[JSON] String :> Put '[JSON] NoContent
:<|> "test" :> Capture "id" Int :> Delete '[JSON] () :<|> "test" :> Capture "id" Int :> Delete '[JSON] NoContent
:<|> "test" :> CaptureAll "ids" Int :> Get '[JSON] [Int]
testApi :: [Req] testApi :: [Req String]
testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy TestApi) testApi = listFromAPI (Proxy :: Proxy LangX) (Proxy :: Proxy String) (Proxy :: Proxy TestApi)
listFromAPISpec :: Spec listFromAPISpec :: Spec
listFromAPISpec = describe "listFromAPI" $ do listFromAPISpec = describe "listFromAPI" $ do
it "generates 4 endpoints for TestApi" $ do it "generates 4 endpoints for TestApi" $ do
length testApi `shouldBe` 4 length testApi `shouldBe` 5
let [getReq, postReq, putReq, deleteReq] = testApi let [getReq, postReq, putReq, deleteReq, captureAllReq] = testApi
it "collects all info for get request" $ do it "collects all info for get request" $ do
shouldBe getReq $ defReq shouldBe getReq $ defReq
{ _reqUrl = Url { _reqUrl = Url
[ Segment $ Static "test" ] [ Segment $ Static "test" ]
[ QueryArg ("flag", "boolX") Flag ] [ QueryArg (Arg "flag" "boolX") Flag ]
, _reqMethod = "GET" , _reqMethod = "GET"
, _reqHeaders = [HeaderArg ("header", "listX of stringX")] , _reqHeaders = [HeaderArg $ Arg "header" "listX of stringX"]
, _reqBody = Nothing , _reqBody = Nothing
, _reqReturnType = "intX" , _reqReturnType = Just "intX"
, _funcName = ["get", "test"] , _reqFuncName = FunctionName ["get", "test"]
} }
it "collects all info for post request" $ do it "collects all info for post request" $ do
shouldBe postReq $ defReq shouldBe postReq $ defReq
{ _reqUrl = Url { _reqUrl = Url
[ Segment $ Static "test" ] [ Segment $ Static "test" ]
[ QueryArg ("param", "intX") Normal ] [ QueryArg (Arg "param" "intX") Normal ]
, _reqMethod = "POST" , _reqMethod = "POST"
, _reqHeaders = [] , _reqHeaders = []
, _reqBody = Just "listX of stringX" , _reqBody = Just "listX of stringX"
, _reqReturnType = "voidX" , _reqReturnType = Just "voidX"
, _funcName = ["post", "test"] , _reqFuncName = FunctionName ["post", "test"]
} }
it "collects all info for put request" $ do it "collects all info for put request" $ do
shouldBe putReq $ defReq shouldBe putReq $ defReq
{ _reqUrl = Url { _reqUrl = Url
[ Segment $ Static "test" ] [ Segment $ Static "test" ]
-- Shoud this be |intX| or |listX of intX| ? -- Shoud this be |intX| or |listX of intX| ?
[ QueryArg ("params", "listX of intX") List ] [ QueryArg (Arg "params" "listX of intX") List ]
, _reqMethod = "PUT" , _reqMethod = "PUT"
, _reqHeaders = [] , _reqHeaders = []
, _reqBody = Just "stringX" , _reqBody = Just "stringX"
, _reqReturnType = "voidX" , _reqReturnType = Just "voidX"
, _funcName = ["put", "test"] , _reqFuncName = FunctionName ["put", "test"]
} }
it "collects all info for delete request" $ do it "collects all info for delete request" $ do
shouldBe deleteReq $ defReq shouldBe deleteReq $ defReq
{ _reqUrl = Url { _reqUrl = Url
[ Segment $ Static "test" [ Segment $ Static "test"
, Segment $ Cap ("id", "intX") ] , Segment $ Cap (Arg "id" "intX") ]
[] []
, _reqMethod = "DELETE" , _reqMethod = "DELETE"
, _reqHeaders = [] , _reqHeaders = []
, _reqBody = Nothing , _reqBody = Nothing
, _reqReturnType = "voidX" , _reqReturnType = Just "voidX"
, _funcName = ["delete", "test", "by", "id"] , _reqFuncName = FunctionName ["delete", "test", "by", "id"]
} }
it "collects all info for capture all request" $ do
shouldBe captureAllReq $ defReq
{ _reqUrl = Url
[ Segment $ Static "test"
, Segment $ Cap (Arg "ids" "listX of intX") ]
[]
, _reqMethod = "GET"
, _reqHeaders = []
, _reqBody = Nothing
, _reqReturnType = Just "listX of intX"
, _reqFuncName = FunctionName ["get", "test", "by", "ids"]
}

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 * 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 * 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 * 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. All rights reserved.

3
servant-js/examples/counter.hs
View file

@ -1,6 +1,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
import Control.Concurrent.STM import Control.Concurrent.STM
@ -92,7 +93,7 @@ main = do
writeJSForAPI testApi (angular defAngularOptions) (www </> "angular" </> "api.js") writeJSForAPI testApi (angular defAngularOptions) (www </> "angular" </> "api.js")
writeJSForAPI testApi axios (www </> "axios" </> "api.js") writeJSForAPI testApi (axios defAxiosOptions) (www </> "axios" </> "api.js")
writeServiceJS (www </> "angular" </> "api.service.js") writeServiceJS (www </> "angular" </> "api.service.js")

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

@ -1,5 +1,5 @@
name: servant-js name: servant-js
version: 0.5 version: 0.8
synopsis: Automatically derive javascript functions to query servant webservices. synopsis: Automatically derive javascript functions to query servant webservices.
description: description:
Automatically derive javascript functions to query servant webservices. Automatically derive javascript functions to query servant webservices.
@ -13,13 +13,13 @@ description:
<https://github.com/haskell-servant/servant/blob/master/servant-js/CHANGELOG.md CHANGELOG> <https://github.com/haskell-servant/servant/blob/master/servant-js/CHANGELOG.md CHANGELOG>
license: BSD3 license: BSD3
license-file: LICENSE license-file: LICENSE
author: Alp Mestanogullari, Maksymilian Owsianny author: Servant Contributors
maintainer: alpmestan@gmail.com maintainer: haskell-servant-maintainers@googlegroups.com
copyright: 2014 Alp Mestanogullari copyright: 2015-2016 Servant Contributors
category: Web category: Web
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
homepage: http://haskell-servant.github.io/ homepage: http://haskell-servant.readthedocs.org/
Bug-reports: http://github.com/haskell-servant/servant/issues Bug-reports: http://github.com/haskell-servant/servant/issues
extra-source-files: extra-source-files:
include/*.h include/*.h
@ -42,9 +42,11 @@ library
Servant.JS.JQuery Servant.JS.JQuery
Servant.JS.Vanilla Servant.JS.Vanilla
build-depends: base >= 4.5 && <5 build-depends: base >= 4.5 && <5
, base-compat >= 0.9
, charset >= 0.3 , charset >= 0.3
, lens >= 4 , lens >= 4
, servant-foreign == 0.5.* , servant-foreign == 0.8.*
, servant == 0.8.*
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
hs-source-dirs: src hs-source-dirs: src
@ -54,7 +56,7 @@ library
executable counter executable counter
main-is: counter.hs main-is: counter.hs
ghc-options: -O2 -Wall ghc-options: -Wall
hs-source-dirs: examples hs-source-dirs: examples
if flag(example) if flag(example)
@ -63,11 +65,11 @@ executable counter
buildable: False buildable: False
build-depends: base >= 4.7 && < 5 build-depends: base >= 4.7 && < 5
, aeson >= 0.7 && < 0.11 , aeson >= 0.7 && < 1.1
, filepath >= 1 , filepath >= 1
, lens >= 4 , lens >= 4
, servant == 0.5.* , servant == 0.8.*
, servant-server == 0.5.* , servant-server == 0.8.*
, servant-js , servant-js
, stm , stm
, transformers , transformers
@ -83,6 +85,7 @@ test-suite spec
Servant.JSSpec Servant.JSSpec
Servant.JSSpec.CustomHeaders Servant.JSSpec.CustomHeaders
build-depends: base build-depends: base
, base-compat
, hspec >= 2.1.8 , hspec >= 2.1.8
, hspec-expectations , hspec-expectations
, language-ecmascript >= 0.16 , language-ecmascript >= 0.16

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

@ -112,38 +112,40 @@ module Servant.JS
, javascript , javascript
, NoTypes , NoTypes
, GenerateList(..) , GenerateList(..)
, FunctionName(..)
) where ) where
import Prelude hiding (writeFile) import Prelude hiding (writeFile)
import Data.Proxy import Data.Proxy
import Data.Text import Data.Text
import Data.Text.IO (writeFile) import Data.Text.IO (writeFile)
import Servant.API.ContentTypes
import Servant.JS.Angular import Servant.JS.Angular
import Servant.JS.Axios import Servant.JS.Axios
import Servant.JS.Internal import Servant.JS.Internal
import Servant.JS.JQuery import Servant.JS.JQuery
import Servant.JS.Vanilla import Servant.JS.Vanilla
import Servant.Foreign (GenerateList(..), listFromAPI, NoTypes) import Servant.Foreign (listFromAPI)
-- | Generate the data necessary to generate javascript code -- | Generate the data necessary to generate javascript code
-- for all the endpoints of an API, as ':<|>'-separated values -- for all the endpoints of an API, as ':<|>'-separated values
-- of type 'AjaxReq'. -- of type 'AjaxReq'.
javascript :: HasForeign NoTypes layout => Proxy layout -> Foreign layout javascript :: HasForeign NoTypes NoContent api => Proxy api -> Foreign NoContent api
javascript p = foreignFor (Proxy :: Proxy NoTypes) p defReq javascript p = foreignFor (Proxy :: Proxy NoTypes) (Proxy :: Proxy NoContent) p defReq
-- | Directly generate all the javascript functions for your API -- | Directly generate all the javascript functions for your API
-- from a 'Proxy' for your API type. You can then write it to -- from a 'Proxy' for your API type. You can then write it to
-- a file or integrate it in a page, for example. -- a file or integrate it in a page, for example.
jsForAPI :: (HasForeign NoTypes api, GenerateList (Foreign api)) jsForAPI :: (HasForeign NoTypes NoContent api, GenerateList NoContent (Foreign NoContent api))
=> Proxy api -- ^ proxy for your API type => Proxy api -- ^ proxy for your API type
-> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> 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 -> 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 NoContent) p)
-- | Directly generate all the javascript functions for your API -- | Directly generate all the javascript functions for your API
-- from a 'Proxy' for your API type using the given generator -- from a 'Proxy' for your API type using the given generator
-- and write the resulting code to a file at the given path. -- and write the resulting code to a file at the given path.
writeJSForAPI :: (HasForeign NoTypes api, GenerateList (Foreign api)) writeJSForAPI :: (HasForeign NoTypes NoContent api, GenerateList NoContent (Foreign NoContent api))
=> Proxy api -- ^ proxy for your API type => Proxy api -- ^ proxy for your API type
-> JavaScriptGenerator -- ^ js code generator to use (angular, vanilla js, jquery, others) -> 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 -> FilePath -- ^ path to the file you want to write the resulting javascript code into

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

@ -76,9 +76,12 @@ generateAngularJSWith ngOptions opts req = "\n" <>
where argsStr = T.intercalate ", " args where argsStr = T.intercalate ", " args
args = http args = http
++ captures ++ captures
++ map (view $ argName._1) queryparams ++ map (view $ queryArgName . argPath) queryparams
++ body ++ 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 -- If we want to generate Top Level Function, they must depend on
-- the $http service, if we generate a service, the functions will -- the $http service, if we generate a service, the functions will
@ -87,9 +90,9 @@ generateAngularJSWith ngOptions opts req = "\n" <>
0 -> ["$http"] 0 -> ["$http"]
_ -> [] _ -> []
captures = map (fst . captureArg) captures = map (view argPath . captureArg)
. filter isCapture . filter isCapture
$ req ^. reqUrl.path $ req ^. reqUrl . path
hs = req ^. reqHeaders hs = req ^. reqHeaders
@ -110,10 +113,11 @@ generateAngularJSWith ngOptions opts req = "\n" <>
then "" then ""
else " , headers: { " <> headersStr <> " }\n" else " , headers: { " <> headersStr <> " }\n"
where headersStr = T.intercalate ", " $ map headerStr hs where
headerStr header = "\"" <> headersStr = T.intercalate ", " $ map headerStr hs
fst (headerArg header) <> headerStr header = "\"" <>
"\": " <> toJSHeader header header ^. headerArg . argPath <>
"\": " <> toJSHeader header
namespace = namespace =
if hasService if hasService
@ -128,7 +132,7 @@ generateAngularJSWith ngOptions opts req = "\n" <>
fsep = if hasService then ":" else " =" fsep = if hasService then ":" else " ="
fname = namespace <> (functionNameBuilder opts $ req ^. funcName) fname = namespace <> (functionNameBuilder opts $ req ^. reqFuncName)
method = req ^. reqMethod method = req ^. reqMethod
url = if url' == "'" then "'/'" else url' url = if url' == "'" then "'/'" else url'

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