commit
eb11fe6b02
50 changed files with 2828 additions and 1767 deletions
4
.gitignore
vendored
4
.gitignore
vendored
|
@ -25,3 +25,7 @@ Setup
|
|||
.stack-work
|
||||
shell.nix
|
||||
default.nix
|
||||
doc/_build
|
||||
doc/venv
|
||||
doc/tutorial/static/api.js
|
||||
doc/tutorial/static/jq.js
|
||||
|
|
216
doc/Makefile
Normal file
216
doc/Makefile
Normal 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
8
doc/building-the-docs
Normal 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
294
doc/conf.py
Normal file
|
@ -0,0 +1,294 @@
|
|||
# -*- coding: utf-8 -*-
|
||||
#
|
||||
# servant documentation build configuration file, created by
|
||||
# sphinx-quickstart on Mon Nov 23 13:24:36 2015.
|
||||
#
|
||||
# This file is execfile()d with the current directory set to its
|
||||
# containing dir.
|
||||
#
|
||||
# Note that not all possible configuration values are present in this
|
||||
# autogenerated file.
|
||||
#
|
||||
# All configuration values have a default; values that are commented out
|
||||
# serve to show the default.
|
||||
|
||||
import sys
|
||||
import os
|
||||
import shlex
|
||||
from recommonmark.parser import CommonMarkParser
|
||||
|
||||
# If extensions (or modules to document with autodoc) are in another directory,
|
||||
# add these directories to sys.path here. If the directory is relative to the
|
||||
# documentation root, use os.path.abspath to make it absolute, like shown here.
|
||||
#sys.path.insert(0, os.path.abspath('.'))
|
||||
|
||||
# -- General configuration ------------------------------------------------
|
||||
|
||||
# If your documentation needs a minimal Sphinx version, state it here.
|
||||
#needs_sphinx = '1.0'
|
||||
|
||||
# Add any Sphinx extension module names here, as strings. They can be
|
||||
# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom
|
||||
# ones.
|
||||
extensions = []
|
||||
|
||||
# Add any paths that contain templates here, relative to this directory.
|
||||
templates_path = ['_templates']
|
||||
|
||||
# The suffix(es) of source filenames.
|
||||
# You can specify multiple suffix as a list of string:
|
||||
source_suffix = ['.md', '.rst', '.lhs']
|
||||
|
||||
# The encoding of source files.
|
||||
#source_encoding = 'utf-8-sig'
|
||||
|
||||
# The master toctree document.
|
||||
master_doc = 'index'
|
||||
|
||||
# General information about the project.
|
||||
project = u'servant'
|
||||
copyright = u'2016, Servant Contributors'
|
||||
author = u'Servant Contributors'
|
||||
|
||||
# The version info for the project you're documenting, acts as replacement for
|
||||
# |version| and |release|, also used in various other places throughout the
|
||||
# built documents.
|
||||
#
|
||||
# The short X.Y version.
|
||||
# version = 'latest'
|
||||
# The full version, including alpha/beta/rc tags.
|
||||
# release = 'latest'
|
||||
|
||||
# The language for content autogenerated by Sphinx. Refer to documentation
|
||||
# for a list of supported languages.
|
||||
#
|
||||
# This is also used if you do content translation via gettext catalogs.
|
||||
# Usually you set "language" from the command line for these cases.
|
||||
language = None
|
||||
|
||||
# There are two options for replacing |today|: either, you set today to some
|
||||
# non-false value, then it is used:
|
||||
#today = ''
|
||||
# Else, today_fmt is used as the format for a strftime call.
|
||||
#today_fmt = '%B %d, %Y'
|
||||
|
||||
# List of patterns, relative to source directory, that match files and
|
||||
# directories to ignore when looking for source files.
|
||||
exclude_patterns = ['_build', 'venv']
|
||||
|
||||
# The reST default role (used for this markup: `text`) to use for all
|
||||
# documents.
|
||||
#default_role = None
|
||||
|
||||
# If true, '()' will be appended to :func: etc. cross-reference text.
|
||||
#add_function_parentheses = True
|
||||
|
||||
# If true, the current module name will be prepended to all description
|
||||
# unit titles (such as .. function::).
|
||||
#add_module_names = True
|
||||
|
||||
# If true, sectionauthor and moduleauthor directives will be shown in the
|
||||
# output. They are ignored by default.
|
||||
#show_authors = False
|
||||
|
||||
# The name of the Pygments (syntax highlighting) style to use.
|
||||
pygments_style = 'sphinx'
|
||||
|
||||
def setup(app):
|
||||
from sphinx.highlighting import lexers
|
||||
from pygments.lexers import HaskellLexer
|
||||
lexers['haskell ignore'] = HaskellLexer(stripnl=False)
|
||||
|
||||
# A list of ignored prefixes for module index sorting.
|
||||
#modindex_common_prefix = []
|
||||
|
||||
# If true, keep warnings as "system message" paragraphs in the built documents.
|
||||
#keep_warnings = False
|
||||
|
||||
# If true, `todo` and `todoList` produce output, else they produce nothing.
|
||||
todo_include_todos = False
|
||||
|
||||
|
||||
# -- Options for HTML output ----------------------------------------------
|
||||
|
||||
# The theme to use for HTML and HTML Help pages. See the documentation for
|
||||
# a list of builtin themes.
|
||||
html_theme = 'sphinx_rtd_theme'
|
||||
|
||||
# Theme options are theme-specific and customize the look and feel of a theme
|
||||
# further. For a list of options available for each theme, see the
|
||||
# documentation.
|
||||
#html_theme_options = {}
|
||||
|
||||
# Add any paths that contain custom themes here, relative to this directory.
|
||||
#html_theme_path = []
|
||||
|
||||
# The name for this set of Sphinx documents. If None, it defaults to
|
||||
# "<project> v<release> documentation".
|
||||
#html_title = None
|
||||
|
||||
# A shorter title for the navigation bar. Default is the same as html_title.
|
||||
#html_short_title = None
|
||||
|
||||
# The name of an image file (relative to this directory) to place at the top
|
||||
# of the sidebar.
|
||||
#html_logo = None
|
||||
|
||||
# The name of an image file (within the static path) to use as favicon of the
|
||||
# docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32
|
||||
# pixels large.
|
||||
#html_favicon = None
|
||||
|
||||
# Add any paths that contain custom static files (such as style sheets) here,
|
||||
# relative to this directory. They are copied after the builtin static files,
|
||||
# so a file named "default.css" will overwrite the builtin "default.css".
|
||||
html_static_path = ['_static']
|
||||
|
||||
# Add any extra paths that contain custom files (such as robots.txt or
|
||||
# .htaccess) here, relative to this directory. These files are copied
|
||||
# directly to the root of the documentation.
|
||||
#html_extra_path = []
|
||||
|
||||
# If not '', a 'Last updated on:' timestamp is inserted at every page bottom,
|
||||
# using the given strftime format.
|
||||
#html_last_updated_fmt = '%b %d, %Y'
|
||||
|
||||
# If true, SmartyPants will be used to convert quotes and dashes to
|
||||
# typographically correct entities.
|
||||
#html_use_smartypants = True
|
||||
|
||||
# Custom sidebar templates, maps document names to template names.
|
||||
#html_sidebars = {}
|
||||
|
||||
# Additional templates that should be rendered to pages, maps page names to
|
||||
# template names.
|
||||
#html_additional_pages = {}
|
||||
|
||||
# If false, no module index is generated.
|
||||
#html_domain_indices = True
|
||||
|
||||
# If false, no index is generated.
|
||||
#html_use_index = True
|
||||
|
||||
# If true, the index is split into individual pages for each letter.
|
||||
#html_split_index = False
|
||||
|
||||
# If true, links to the reST sources are added to the pages.
|
||||
#html_show_sourcelink = True
|
||||
|
||||
# If true, "Created using Sphinx" is shown in the HTML footer. Default is True.
|
||||
#html_show_sphinx = True
|
||||
|
||||
# If true, "(C) Copyright ..." is shown in the HTML footer. Default is True.
|
||||
#html_show_copyright = True
|
||||
|
||||
# If true, an OpenSearch description file will be output, and all pages will
|
||||
# contain a <link> tag referring to it. The value of this option must be the
|
||||
# base URL from which the finished HTML is served.
|
||||
#html_use_opensearch = ''
|
||||
|
||||
# This is the file name suffix for HTML files (e.g. ".xhtml").
|
||||
#html_file_suffix = None
|
||||
|
||||
# Language to be used for generating the HTML full-text search index.
|
||||
# Sphinx supports the following languages:
|
||||
# 'da', 'de', 'en', 'es', 'fi', 'fr', 'hu', 'it', 'ja'
|
||||
# 'nl', 'no', 'pt', 'ro', 'ru', 'sv', 'tr'
|
||||
#html_search_language = 'en'
|
||||
|
||||
# A dictionary with options for the search language support, empty by default.
|
||||
# Now only 'ja' uses this config value
|
||||
#html_search_options = {'type': 'default'}
|
||||
|
||||
# The name of a javascript file (relative to the configuration directory) that
|
||||
# implements a search results scorer. If empty, the default will be used.
|
||||
#html_search_scorer = 'scorer.js'
|
||||
|
||||
# Output file base name for HTML help builder.
|
||||
htmlhelp_basename = 'servantdoc'
|
||||
|
||||
# -- Options for LaTeX output ---------------------------------------------
|
||||
|
||||
latex_elements = {
|
||||
# The paper size ('letterpaper' or 'a4paper').
|
||||
#'papersize': 'letterpaper',
|
||||
|
||||
# The font size ('10pt', '11pt' or '12pt').
|
||||
#'pointsize': '10pt',
|
||||
|
||||
# Additional stuff for the LaTeX preamble.
|
||||
#'preamble': '',
|
||||
|
||||
# Latex figure (float) alignment
|
||||
#'figure_align': 'htbp',
|
||||
}
|
||||
|
||||
# Grouping the document tree into LaTeX files. List of tuples
|
||||
# (source start file, target name, title,
|
||||
# author, documentclass [howto, manual, or own class]).
|
||||
latex_documents = [
|
||||
(master_doc, 'servant.tex', u'servant Documentation',
|
||||
u'Servant Contributors', 'manual'),
|
||||
]
|
||||
|
||||
# The name of an image file (relative to this directory) to place at the top of
|
||||
# the title page.
|
||||
#latex_logo = None
|
||||
|
||||
# For "manual" documents, if this is true, then toplevel headings are parts,
|
||||
# not chapters.
|
||||
#latex_use_parts = False
|
||||
|
||||
# If true, show page references after internal links.
|
||||
#latex_show_pagerefs = False
|
||||
|
||||
# If true, show URL addresses after external links.
|
||||
#latex_show_urls = False
|
||||
|
||||
# Documents to append as an appendix to all manuals.
|
||||
#latex_appendices = []
|
||||
|
||||
# If false, no module index is generated.
|
||||
#latex_domain_indices = True
|
||||
|
||||
|
||||
# -- Options for manual page output ---------------------------------------
|
||||
|
||||
# One entry per manual page. List of tuples
|
||||
# (source start file, name, description, authors, manual section).
|
||||
man_pages = [
|
||||
(master_doc, 'servant', u'servant Documentation',
|
||||
[author], 1)
|
||||
]
|
||||
|
||||
# If true, show URL addresses after external links.
|
||||
#man_show_urls = False
|
||||
|
||||
|
||||
# -- Options for Texinfo output -------------------------------------------
|
||||
|
||||
# Grouping the document tree into Texinfo files. List of tuples
|
||||
# (source start file, target name, title, author,
|
||||
# dir menu entry, description, category)
|
||||
texinfo_documents = [
|
||||
(master_doc, 'servant', u'servant Documentation',
|
||||
author, 'servant', 'One line description of project.',
|
||||
'Miscellaneous'),
|
||||
]
|
||||
|
||||
# Documents to append as an appendix to all manuals.
|
||||
#texinfo_appendices = []
|
||||
|
||||
# If false, no module index is generated.
|
||||
#texinfo_domain_indices = True
|
||||
|
||||
# How to display URL addresses: 'footnote', 'no', or 'inline'.
|
||||
#texinfo_show_urls = 'footnote'
|
||||
|
||||
# If true, do not generate a @detailmenu in the "Top" node's menu.
|
||||
#texinfo_no_detailmenu = False
|
||||
|
||||
source_parsers = {
|
||||
'.md': CommonMarkParser,
|
||||
'.lhs': CommonMarkParser,
|
||||
}
|
22
doc/index.rst
Normal file
22
doc/index.rst
Normal file
|
@ -0,0 +1,22 @@
|
|||
servant – A Type-Level Web DSL
|
||||
==============================
|
||||
|
||||
.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png
|
||||
|
||||
**servant** is a set of packages for declaring web APIs at the type-level and
|
||||
then using those API specifications to:
|
||||
|
||||
- write servers (this part of **servant** can be considered a web framework),
|
||||
- obtain client functions (in haskell),
|
||||
- generate client functions for other programming languages,
|
||||
- generate documentation for your web applications
|
||||
- and more...
|
||||
|
||||
All in a type-safe manner.
|
||||
|
||||
.. toctree::
|
||||
:maxdepth: 2
|
||||
|
||||
introduction.rst
|
||||
tutorial/index.rst
|
||||
links.rst
|
40
doc/introduction.rst
Normal file
40
doc/introduction.rst
Normal 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
34
doc/links.rst
Normal 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
25
doc/requirements.txt
Normal file
|
@ -0,0 +1,25 @@
|
|||
alabaster==0.7.7
|
||||
argh==0.26.1
|
||||
Babel==2.2.0
|
||||
backports-abc==0.4
|
||||
backports.ssl-match-hostname==3.5.0.1
|
||||
certifi==2015.11.20.1
|
||||
CommonMark==0.5.4
|
||||
docutils==0.12
|
||||
Jinja2==2.8
|
||||
livereload==2.4.1
|
||||
MarkupSafe==0.23
|
||||
pathtools==0.1.2
|
||||
Pygments==2.1.1
|
||||
pytz==2015.7
|
||||
PyYAML==3.11
|
||||
recommonmark==0.4.0
|
||||
singledispatch==3.4.0.3
|
||||
six==1.10.0
|
||||
snowballstemmer==1.2.1
|
||||
Sphinx==1.3.4
|
||||
sphinx-autobuild==0.5.2
|
||||
sphinx-rtd-theme==0.1.9
|
||||
tornado==4.3
|
||||
watchdog==0.8.3
|
||||
wheel==0.26.0
|
1
doc/tutorial/.ghci
Normal file
1
doc/tutorial/.ghci
Normal file
|
@ -0,0 +1 @@
|
|||
:set -pgmL markdown-unlit -Wall -Werror -fno-warn-missing-methods -fno-warn-name-shadowing -itest
|
311
doc/tutorial/ApiType.lhs
Normal file
311
doc/tutorial/ApiType.lhs
Normal file
|
@ -0,0 +1,311 @@
|
|||
# A web API as a type
|
||||
|
||||
The source for this tutorial section is a literate haskell file, so first we
|
||||
need to have some language extensions and imports:
|
||||
|
||||
``` haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module ApiType where
|
||||
|
||||
import Data.Text
|
||||
import Servant.API
|
||||
```
|
||||
|
||||
Consider the following informal specification of an API:
|
||||
|
||||
> The endpoint at `/users` expects a GET request with query string parameter
|
||||
> `sortby` whose value can be one of `age` or `name` and returns a
|
||||
> list/array of JSON objects describing users, with fields `age`, `name`,
|
||||
> `email`, `registration_date`".
|
||||
|
||||
You *should* be able to formalize that. And then use the formalized version to
|
||||
get you much of the way towards writing a web app. And all the way towards
|
||||
getting some client libraries, and documentation, and more.
|
||||
|
||||
How would we describe it with **servant**? An endpoint description is a good old
|
||||
Haskell **type**:
|
||||
|
||||
``` haskell
|
||||
type UserAPI = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User]
|
||||
|
||||
data SortBy = Age | Name
|
||||
|
||||
data User = User {
|
||||
name :: String,
|
||||
age :: Int
|
||||
}
|
||||
```
|
||||
|
||||
Let's break that down:
|
||||
|
||||
- `"users"` says that our endpoint will be accessible under `/users`;
|
||||
- `QueryParam "sortby" SortBy`, where `SortBy` is defined by `data SortBy = Age | Name`,
|
||||
says that the endpoint has a query string parameter named `sortby`
|
||||
whose value will be extracted as a value of type `SortBy`.
|
||||
- `Get '[JSON] [User]` says that the endpoint will be accessible through HTTP
|
||||
GET requests, returning a list of users encoded as JSON. You will see
|
||||
later how you can make use of this to make your data available under different
|
||||
formats, the choice being made depending on the [Accept
|
||||
header](http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html) specified in
|
||||
the client's request.
|
||||
- The `:>` operator that separates the various "combinators" just lets you
|
||||
sequence static path fragments, URL captures and other combinators. The
|
||||
ordering only matters for static path fragments and URL captures. `"users" :>
|
||||
"list-all" :> Get '[JSON] [User]`, equivalent to `/users/list-all`, is
|
||||
obviously not the same as `"list-all" :> "users" :> Get '[JSON] [User]`, which
|
||||
is equivalent to `/list-all/users`. This means that sometimes `:>` is somehow
|
||||
equivalent to `/`, but sometimes it just lets you chain another combinator.
|
||||
|
||||
We can also describe APIs with multiple endpoints by using the `:<|>`
|
||||
combinators. Here's an example:
|
||||
|
||||
``` haskell
|
||||
type UserAPI2 = "users" :> "list-all" :> Get '[JSON] [User]
|
||||
:<|> "list-all" :> "users" :> Get '[JSON] [User]
|
||||
```
|
||||
|
||||
**servant** provides a fair amount of combinators out-of-the-box, but you can
|
||||
always write your own when you need it. Here's a quick overview of the most
|
||||
often needed the combinators that **servant** comes with.
|
||||
|
||||
## Combinators
|
||||
|
||||
### Static strings
|
||||
|
||||
As you've already seen, you can use type-level strings (enabled with the
|
||||
`DataKinds` language extension) for static path fragments. Chaining
|
||||
them amounts to `/`-separating them in a URL.
|
||||
|
||||
``` haskell
|
||||
type UserAPI3 = "users" :> "list-all" :> "now" :> Get '[JSON] [User]
|
||||
-- describes an endpoint reachable at:
|
||||
-- /users/list-all/now
|
||||
```
|
||||
|
||||
### `Delete`, `Get`, `Patch`, `Post` and `Put`
|
||||
|
||||
The `Get` combinator is defined in terms of the more general `Verb`:
|
||||
``` haskell ignore
|
||||
data Verb method (statusCode :: Nat) (contentType :: [*]) a
|
||||
type Get = Verb 'GET 200
|
||||
```
|
||||
|
||||
There are other predefined type synonyms for other common HTTP methods,
|
||||
such as e.g.:
|
||||
``` haskell ignore
|
||||
data Delete = Verb 'DELETE 200
|
||||
data Patch = Verb 'PATCH 200
|
||||
data Post = Verb 'POST 200
|
||||
data 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
|
||||
[`FromText`](https://hackage.haskell.org/package/servant/docs/Servant-Common-Text.html#t:FromText)
|
||||
class, which the captured value must be an instance of.
|
||||
|
||||
Examples:
|
||||
|
||||
``` haskell
|
||||
type UserAPI5 = "user" :> Capture "userid" Integer :> Get '[JSON] User
|
||||
-- equivalent to 'GET /user/:userid'
|
||||
-- except that we explicitly say that "userid"
|
||||
-- must be an integer
|
||||
|
||||
:<|> "user" :> Capture "userid" Integer :> DeleteNoContent '[JSON] NoContent
|
||||
-- equivalent to 'DELETE /user/:userid'
|
||||
```
|
||||
|
||||
In the second case, `DeleteNoContent` specifies a 204 response code,
|
||||
`JSON` specifies the content types on which the handler will match,
|
||||
and `NoContent` says that the response will always be empty.
|
||||
|
||||
### `QueryParam`, `QueryParams`, `QueryFlag`
|
||||
|
||||
`QueryParam`, `QueryParams` and `QueryFlag` are about parameters in the query string,
|
||||
i.e., those parameters that come after the question mark
|
||||
(`?`) in URLs, like `sortby` in `/users?sortby=age`, whose value is
|
||||
set to `age`. `QueryParams` lets you specify that the query parameter
|
||||
is actually a list of values, which can be specified using
|
||||
`?param=value1¶m=value2`. This represents a list of values
|
||||
composed of `value1` and `value2`. `QueryFlag` lets you specify a
|
||||
boolean-like query parameter where a client isn't forced to specify a
|
||||
value. The absence or presence of the parameter's name in the query
|
||||
string determines whether the parameter is considered to have the
|
||||
value `True` or `False`. For instance, `/users?active` would list only
|
||||
active users whereas `/users` would list them all.
|
||||
|
||||
Here are the corresponding data type declarations:
|
||||
|
||||
``` haskell ignore
|
||||
data QueryParam (sym :: Symbol) a
|
||||
data QueryParams (sym :: Symbol) a
|
||||
data QueryFlag (sym :: Symbol)
|
||||
```
|
||||
|
||||
Examples:
|
||||
|
||||
``` haskell
|
||||
type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User]
|
||||
-- equivalent to 'GET /users?sortby={age, name}'
|
||||
|
||||
```
|
||||
|
||||
Again, your handlers don't have to deserialize these things (into, for example,
|
||||
a `SortBy`). **servant** takes care of it.
|
||||
|
||||
### `ReqBody`
|
||||
|
||||
Each HTTP request can carry some additional data that the server can use in its
|
||||
*body*, and this data can be encoded in any format -- as long as the server
|
||||
understands it. This can be used for example for an endpoint for creating new
|
||||
users: instead of passing each field of the user as a separate query string
|
||||
parameter or something dirty like that, we can group all the data into a JSON
|
||||
object. This has the advantage of supporting nested objects.
|
||||
|
||||
**servant**'s `ReqBody` combinator takes a list of content types in which the
|
||||
data encoded in the request body can be represented and the type of that data.
|
||||
And, as you might have guessed, you don't have to check the content type
|
||||
header, and do the deserialization yourself. We do it for you. And return `Bad
|
||||
Request` or `Unsupported Content Type` as appropriate.
|
||||
|
||||
Here's the data type declaration for it:
|
||||
|
||||
``` haskell ignore
|
||||
data ReqBody (contentTypes :: [*]) a
|
||||
```
|
||||
|
||||
Examples:
|
||||
|
||||
``` haskell
|
||||
type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User
|
||||
-- - equivalent to 'POST /users' with a JSON object
|
||||
-- describing a User in the request body
|
||||
-- - returns a User encoded in JSON
|
||||
|
||||
:<|> "users" :> Capture "userid" Integer
|
||||
:> ReqBody '[JSON] User
|
||||
:> Put '[JSON] User
|
||||
-- - equivalent to 'PUT /users/:userid' with a JSON
|
||||
-- object describing a User in the request body
|
||||
-- - returns a User encoded in JSON
|
||||
```
|
||||
|
||||
### Request `Header`s
|
||||
|
||||
Request headers are used for various purposes, from caching to carrying
|
||||
auth-related data. They consist of a header name and an associated value. An
|
||||
example would be `Accept: application/json`.
|
||||
|
||||
The `Header` combinator in **servant** takes a type-level string for the header
|
||||
name and the type to which we want to decode the header's value (from some
|
||||
textual representation), as illustrated below:
|
||||
|
||||
``` haskell ignore
|
||||
data Header (sym :: Symbol) a
|
||||
```
|
||||
|
||||
Here's an example where we declare that an endpoint makes use of the
|
||||
`User-Agent` header which specifies the name of the software/library used by
|
||||
the client to send the request.
|
||||
|
||||
``` haskell
|
||||
type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User]
|
||||
```
|
||||
|
||||
### Content types
|
||||
|
||||
So far, whenever we have used a combinator that carries a list of content
|
||||
types, we've always specified `'[JSON]`. However, **servant** lets you use several
|
||||
content types, and also lets you define your own content types.
|
||||
|
||||
Four content types are provided out-of-the-box by the core **servant** package:
|
||||
`JSON`, `PlainText`, `FormUrlEncoded` and `OctetStream`. If for some obscure
|
||||
reason you wanted one of your endpoints to make your user data available under
|
||||
those 4 formats, you would write the API type as below:
|
||||
|
||||
``` haskell
|
||||
type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User]
|
||||
```
|
||||
|
||||
(There are other packages that provide other content types. For example
|
||||
**servant-lucid** and **servant-blaze** allow to generate html pages (using
|
||||
**lucid** and **blaze-html**) and both come with a content type for html.)
|
||||
|
||||
We will further explain how these content types and your data types can play
|
||||
together in the [section about serving an API](Server.html).
|
||||
|
||||
### Response `Headers`
|
||||
|
||||
Just like an HTTP request, the response generated by a webserver can carry
|
||||
headers too. **servant** provides a `Headers` combinator that carries a list of
|
||||
`Header` types and can be used by simply wrapping the "return type" of an endpoint
|
||||
with it.
|
||||
|
||||
``` haskell ignore
|
||||
data Headers (ls :: [*]) a
|
||||
```
|
||||
|
||||
If you want to describe an endpoint that returns a "User-Count" header in each
|
||||
response, you could write it as below:
|
||||
|
||||
``` haskell
|
||||
type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User])
|
||||
```
|
||||
|
||||
### 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`.
|
156
doc/tutorial/Client.lhs
Normal file
156
doc/tutorial/Client.lhs
Normal file
|
@ -0,0 +1,156 @@
|
|||
# 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
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import System.IO.Unsafe
|
||||
```
|
||||
|
||||
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"
|
||||
-> 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
|
||||
```
|
||||
|
||||
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 three arguments:
|
||||
|
||||
- a `Proxy` to your API,
|
||||
- a `BaseUrl`, consisting of the protocol, the host, the port and an optional subpath --
|
||||
this basically tells `client` where the service that you want to query is hosted,
|
||||
- a `Manager`, (from [http-client](http://hackage.haskell.org/package/http-client))
|
||||
which manages http connections.
|
||||
|
||||
``` haskell
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
{-# NOINLINE __manager #-}
|
||||
__manager :: Manager
|
||||
__manager = unsafePerformIO $ newManager defaultManagerSettings
|
||||
|
||||
position :<|> hello :<|> marketing =
|
||||
client api (BaseUrl Http "localhost" 8081 "") __manager
|
||||
```
|
||||
|
||||
(Yes, the usage of `unsafePerformIO` is very ugly, we know. Hopefully soon it'll
|
||||
be possible to do without.)
|
||||
|
||||
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 :: ExceptT ServantError IO (Position, HelloMessage, Email)
|
||||
queries = do
|
||||
pos <- position 10 10
|
||||
message <- hello (Just "servant")
|
||||
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
|
||||
return (pos, message, em)
|
||||
|
||||
run :: IO ()
|
||||
run = do
|
||||
res <- runExceptT queries
|
||||
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
234
doc/tutorial/Docs.lhs
Normal file
|
@ -0,0 +1,234 @@
|
|||
# Documenting an API
|
||||
|
||||
The source for this tutorial section is a literate haskell file, so first we
|
||||
need to have some language extensions and imports:
|
||||
|
||||
``` haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Docs where
|
||||
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Proxy
|
||||
import Data.Text.Lazy.Encoding (encodeUtf8)
|
||||
import Data.Text.Lazy (pack)
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Servant.API
|
||||
import Servant.Docs
|
||||
import Servant.Server
|
||||
```
|
||||
|
||||
And we'll import some things from one of our earlier modules
|
||||
([Serving an API](Server.html)):
|
||||
|
||||
``` haskell
|
||||
import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..),
|
||||
server3, emailForClient)
|
||||
```
|
||||
|
||||
Like client function generation, documentation generation amounts to inspecting the API type and extracting all the data we need to then present it in some format to users of your API.
|
||||
|
||||
This time however, we have to assist **servant**. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier:
|
||||
|
||||
``` haskell
|
||||
type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position
|
||||
:<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage
|
||||
:<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email
|
||||
|
||||
exampleAPI :: Proxy ExampleAPI
|
||||
exampleAPI = Proxy
|
||||
```
|
||||
|
||||
While **servant** can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required.
|
||||
|
||||
For every capture, request body, response body, query param, we have to give some explanations about how it influences the response, what values are possible and the likes. Here's how it looks like for the parameters we have above.
|
||||
|
||||
``` haskell
|
||||
instance ToCapture (Capture "x" Int) where
|
||||
toCapture _ =
|
||||
DocCapture "x" -- name
|
||||
"(integer) position on the x axis" -- description
|
||||
|
||||
instance ToCapture (Capture "y" Int) where
|
||||
toCapture _ =
|
||||
DocCapture "y" -- name
|
||||
"(integer) position on the y axis" -- description
|
||||
|
||||
instance ToSample Position where
|
||||
toSamples _ = singleSample (Position 3 14) -- example of output
|
||||
|
||||
instance ToParam (QueryParam "name" String) where
|
||||
toParam _ =
|
||||
DocQueryParam "name" -- name
|
||||
["Alp", "John Doe", "..."] -- example of values (not necessarily exhaustive)
|
||||
"Name of the person to say hello to." -- description
|
||||
Normal -- Normal, List or Flag
|
||||
|
||||
instance ToSample HelloMessage where
|
||||
toSamples _ =
|
||||
[ ("When a value is provided for 'name'", HelloMessage "Hello, Alp")
|
||||
, ("When 'name' is not specified", HelloMessage "Hello, anonymous coward")
|
||||
]
|
||||
-- mutliple examples to display this time
|
||||
|
||||
ci :: ClientInfo
|
||||
ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
|
||||
|
||||
instance ToSample ClientInfo where
|
||||
toSamples _ = singleSample ci
|
||||
|
||||
instance ToSample Email where
|
||||
toSamples _ = singleSample (emailForClient ci)
|
||||
```
|
||||
|
||||
Types that are used as request or response bodies have to instantiate the `ToSample` typeclass which lets you specify one or more examples of values. `Capture`s and `QueryParam`s have to instantiate their respective `ToCapture` and `ToParam` classes and provide a name and some information about the concrete meaning of that argument, as illustrated in the code above.
|
||||
|
||||
With all of this, we can derive docs for our API.
|
||||
|
||||
``` haskell
|
||||
apiDocs :: API
|
||||
apiDocs = docs exampleAPI
|
||||
```
|
||||
|
||||
`API` is a type provided by **servant-docs** that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, **servant-docs** only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [**servant-pandoc**](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats.
|
||||
|
||||
**servant**'s markdown pretty printer is a function named `markdown`.
|
||||
|
||||
``` haskell ignore
|
||||
markdown :: API -> String
|
||||
```
|
||||
|
||||
That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`.
|
||||
|
||||
````````` text
|
||||
## Welcome
|
||||
|
||||
This is our super webservice's API.
|
||||
|
||||
Enjoy!
|
||||
|
||||
## GET /hello
|
||||
|
||||
#### GET Parameters:
|
||||
|
||||
- name
|
||||
- **Values**: *Alp, John Doe, ...*
|
||||
- **Description**: Name of the person to say hello to.
|
||||
|
||||
|
||||
#### Response:
|
||||
|
||||
- Status code 200
|
||||
- Headers: []
|
||||
|
||||
- Supported content types are:
|
||||
|
||||
- `application/json`
|
||||
|
||||
- When a value is provided for 'name'
|
||||
|
||||
```javascript
|
||||
{"msg":"Hello, Alp"}
|
||||
```
|
||||
|
||||
- When 'name' is not specified
|
||||
|
||||
```javascript
|
||||
{"msg":"Hello, anonymous coward"}
|
||||
```
|
||||
|
||||
## POST /marketing
|
||||
|
||||
#### Request:
|
||||
|
||||
- Supported content types are:
|
||||
|
||||
- `application/json`
|
||||
|
||||
- Example: `application/json`
|
||||
|
||||
```javascript
|
||||
{"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"}
|
||||
```
|
||||
|
||||
#### Response:
|
||||
|
||||
- Status code 201
|
||||
- Headers: []
|
||||
|
||||
- Supported content types are:
|
||||
|
||||
- `application/json`
|
||||
|
||||
- Response body as below.
|
||||
|
||||
```javascript
|
||||
{"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"}
|
||||
```
|
||||
|
||||
## GET /position/:x/:y
|
||||
|
||||
#### Captures:
|
||||
|
||||
- *x*: (integer) position on the x axis
|
||||
- *y*: (integer) position on the y axis
|
||||
|
||||
#### Response:
|
||||
|
||||
- Status code 200
|
||||
- Headers: []
|
||||
|
||||
- Supported content types are:
|
||||
|
||||
- `application/json`
|
||||
|
||||
- Response body as below.
|
||||
|
||||
```javascript
|
||||
{"x":3,"y":14}
|
||||
```
|
||||
|
||||
`````````
|
||||
|
||||
However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what **wai** expects for `Raw` endpoints.
|
||||
|
||||
``` haskell
|
||||
docsBS :: ByteString
|
||||
docsBS = encodeUtf8
|
||||
. pack
|
||||
. markdown
|
||||
$ docsWithIntros [intro] exampleAPI
|
||||
|
||||
where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"]
|
||||
```
|
||||
|
||||
`docsWithIntros` just takes an additional parameter, a list of `DocIntro`s that must be displayed before any endpoint docs.
|
||||
|
||||
We can now serve the API *and* the API docs with a simple server.
|
||||
|
||||
``` haskell
|
||||
type DocsAPI = ExampleAPI :<|> Raw
|
||||
|
||||
api :: Proxy DocsAPI
|
||||
api = Proxy
|
||||
|
||||
server :: Server DocsAPI
|
||||
server = Server.server3 :<|> serveDocs
|
||||
|
||||
where serveDocs _ respond =
|
||||
respond $ responseLBS ok200 [plain] docsBS
|
||||
|
||||
plain = ("Content-Type", "text/plain")
|
||||
|
||||
app :: Application
|
||||
app = serve api server
|
||||
```
|
||||
|
||||
And if you spin up this server and request anything else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type.
|
228
doc/tutorial/Javascript.lhs
Normal file
228
doc/tutorial/Javascript.lhs
Normal file
|
@ -0,0 +1,228 @@
|
|||
# Generating Javascript functions to query an API
|
||||
|
||||
We will now see how **servant** lets you turn an API type into javascript
|
||||
functions that you can call to query a webservice.
|
||||
|
||||
For this, we will consider a simple page divided in two parts. At the top, we
|
||||
will have a search box that lets us search in a list of Haskell books by
|
||||
author/title with a list of results that gets updated every time we enter or
|
||||
remove a character, while at the bottom we will be able to see the classical
|
||||
[probabilistic method to approximate
|
||||
pi](http://en.wikipedia.org/wiki/Approximations_of_%CF%80#Summing_a_circle.27s_area),
|
||||
using a webservice to get random points. Finally, we will serve an HTML file
|
||||
along with a couple of Javascript files, among which one that's automatically
|
||||
generated from the API type and which will provide ready-to-use functions to
|
||||
query your API.
|
||||
|
||||
The source for this tutorial section is a literate haskell file, so first we
|
||||
need to have some language extensions and imports:
|
||||
|
||||
``` haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Javascript where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Data.Text as T (Text)
|
||||
import Data.Text.IO as T (writeFile, readFile)
|
||||
import GHC.Generics
|
||||
import Language.Javascript.JQuery
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import qualified Data.Text as T
|
||||
import Servant
|
||||
import Servant.JS
|
||||
import System.Random
|
||||
```
|
||||
|
||||
Now let's have the API type(s) and the accompanying datatypes.
|
||||
|
||||
``` haskell
|
||||
type API = "point" :> Get '[JSON] Point
|
||||
:<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book)
|
||||
|
||||
type API' = API :<|> Raw
|
||||
|
||||
data Point = Point
|
||||
{ x :: Double
|
||||
, y :: Double
|
||||
} deriving Generic
|
||||
|
||||
instance ToJSON Point
|
||||
|
||||
data Search a = Search
|
||||
{ query :: Text
|
||||
, results :: [a]
|
||||
} deriving Generic
|
||||
|
||||
mkSearch :: Text -> [a] -> Search a
|
||||
mkSearch = Search
|
||||
|
||||
instance ToJSON a => ToJSON (Search a)
|
||||
|
||||
data Book = Book
|
||||
{ author :: Text
|
||||
, title :: Text
|
||||
, year :: Int
|
||||
} deriving Generic
|
||||
|
||||
instance ToJSON Book
|
||||
|
||||
book :: Text -> Text -> Int -> Book
|
||||
book = Book
|
||||
```
|
||||
|
||||
We need a "book database". For the purpose of this guide, let's restrict
|
||||
ourselves to the following books.
|
||||
|
||||
``` haskell
|
||||
books :: [Book]
|
||||
books =
|
||||
[ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000
|
||||
, book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008
|
||||
, book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011
|
||||
, book "Graham Hutton" "Programming in Haskell" 2007
|
||||
, book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013
|
||||
, book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998
|
||||
]
|
||||
```
|
||||
|
||||
Now, given an optional search string `q`, we want to perform a case insensitive
|
||||
search in that list of books. We're obviously not going to try and implement
|
||||
the best possible algorithm, this is out of scope for this tutorial. The
|
||||
following simple linear scan will do, given how small our list is.
|
||||
|
||||
``` haskell
|
||||
searchBook :: Monad m => Maybe Text -> m (Search Book)
|
||||
searchBook Nothing = return (mkSearch "" books)
|
||||
searchBook (Just q) = return (mkSearch q books')
|
||||
|
||||
where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b)
|
||||
|| q' `T.isInfixOf` T.toLower (title b)
|
||||
)
|
||||
books
|
||||
q' = T.toLower q
|
||||
```
|
||||
|
||||
We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y
|
||||
<= 1`. The code below uses
|
||||
[random](http://hackage.haskell.org/package/random)'s `System.Random`.
|
||||
|
||||
``` haskell
|
||||
randomPoint :: MonadIO m => m Point
|
||||
randomPoint = liftIO . getStdRandom $ \g ->
|
||||
let (rx, g') = randomR (-1, 1) g
|
||||
(ry, g'') = randomR (-1, 1) g'
|
||||
in (Point rx ry, g'')
|
||||
```
|
||||
|
||||
If we add static file serving, our server is now complete.
|
||||
|
||||
``` haskell
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
api' :: Proxy API'
|
||||
api' = Proxy
|
||||
|
||||
server :: Server API
|
||||
server = randomPoint
|
||||
:<|> searchBook
|
||||
|
||||
server' :: Server API'
|
||||
server' = server
|
||||
:<|> serveDirectory "static"
|
||||
|
||||
app :: Application
|
||||
app = serve api' server'
|
||||
|
||||
main :: IO ()
|
||||
main = run 8000 app
|
||||
```
|
||||
|
||||
Why two different API types, proxies and servers though? Simply because we
|
||||
don't want to generate javascript functions for the `Raw` part of our API type,
|
||||
so we need a `Proxy` for our API type `API'` without its `Raw` endpoint.
|
||||
|
||||
Very similarly to how one can derive haskell functions, we can derive the
|
||||
javascript with just a simple function call to `jsForAPI` from
|
||||
`Servant.JQuery`.
|
||||
|
||||
``` haskell
|
||||
apiJS :: Text
|
||||
apiJS = jsForAPI api vanillaJS
|
||||
```
|
||||
|
||||
This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks':
|
||||
|
||||
``` javascript
|
||||
var getPoint = function(onSuccess, onError)
|
||||
{
|
||||
var xhr = new XMLHttpRequest();
|
||||
xhr.open('GET', '/point', true);
|
||||
xhr.setRequestHeader("Accept","application/json");
|
||||
xhr.onreadystatechange = function (e) {
|
||||
if (xhr.readyState == 4) {
|
||||
if (xhr.status == 204 || xhr.status == 205) {
|
||||
onSuccess();
|
||||
} else if (xhr.status >= 200 && xhr.status < 300) {
|
||||
var value = JSON.parse(xhr.responseText);
|
||||
onSuccess(value);
|
||||
} else {
|
||||
var value = JSON.parse(xhr.responseText);
|
||||
onError(value);
|
||||
}
|
||||
}
|
||||
}
|
||||
xhr.send(null);
|
||||
}
|
||||
|
||||
var getBooks = function(q, onSuccess, onError)
|
||||
{
|
||||
var xhr = new XMLHttpRequest();
|
||||
xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true);
|
||||
xhr.setRequestHeader("Accept","application/json");
|
||||
xhr.onreadystatechange = function (e) {
|
||||
if (xhr.readyState == 4) {
|
||||
if (xhr.status == 204 || xhr.status == 205) {
|
||||
onSuccess();
|
||||
} else if (xhr.status >= 200 && xhr.status < 300) {
|
||||
var value = JSON.parse(xhr.responseText);
|
||||
onSuccess(value);
|
||||
} else {
|
||||
var value = JSON.parse(xhr.responseText);
|
||||
onError(value);
|
||||
}
|
||||
}
|
||||
}
|
||||
xhr.send(null);
|
||||
}
|
||||
```
|
||||
|
||||
We created a directory `static` that contains two static files: `index.html`,
|
||||
which is the entrypoint to our little web application; and `ui.js`, which
|
||||
contains some hand-written javascript. This javascript code assumes the two
|
||||
generated functions `getPoint` and `getBooks` in scope. Therefore we need to
|
||||
write the generated javascript into a file:
|
||||
|
||||
``` haskell
|
||||
writeJSFiles :: IO ()
|
||||
writeJSFiles = do
|
||||
T.writeFile "static/api.js" apiJS
|
||||
jq <- T.readFile =<< Language.Javascript.JQuery.file
|
||||
T.writeFile "static/jq.js" jq
|
||||
```
|
||||
|
||||
(We're also writing the jquery library into a file, as it's also used by
|
||||
`ui.js`.) `static/api.js` will be included in `index.html` and the two
|
||||
generated functions will therefore be available in `ui.js`.
|
||||
|
||||
And we're good to go. You can start the `main` function of this file and go to
|
||||
`http://localhost:8000/`. Start typing in the name of one of the authors in our
|
||||
database or part of a book title, and check out how long it takes to
|
||||
approximate pi using the method mentioned above.
|
|
@ -1,4 +1,4 @@
|
|||
Copyright (c) 2015-2016, Servant Contributors
|
||||
Copyright (c) 2016, Servant Contributors
|
||||
|
||||
All rights reserved.
|
||||
|
||||
|
@ -13,7 +13,7 @@ modification, are permitted provided that the following conditions are met:
|
|||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Alp Mestanogullari nor the names of other
|
||||
* Neither the name of Servant Contributors nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
1115
doc/tutorial/Server.lhs
Normal file
1115
doc/tutorial/Server.lhs
Normal file
File diff suppressed because it is too large
Load diff
2
doc/tutorial/Setup.hs
Normal file
2
doc/tutorial/Setup.hs
Normal file
|
@ -0,0 +1,2 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
18
doc/tutorial/index.rst
Normal file
18
doc/tutorial/index.rst
Normal file
|
@ -0,0 +1,18 @@
|
|||
Tutorial
|
||||
========
|
||||
|
||||
This is an introductory tutorial to **servant**.
|
||||
|
||||
(Any comments, issues or feedback about the tutorial can be handled
|
||||
through
|
||||
`servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
|
||||
|
||||
|
||||
.. toctree::
|
||||
:maxdepth: 1
|
||||
|
||||
ApiType.lhs
|
||||
Server.lhs
|
||||
Client.lhs
|
||||
Javascript.lhs
|
||||
Docs.lhs
|
|
@ -3,11 +3,11 @@
|
|||
<head>
|
||||
<meta name="viewport" content="width=device-width, initial-scale=1">
|
||||
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
|
||||
<title>Tutorial - 9 - servant-jquery</title>
|
||||
<title>servant-js Example</title>
|
||||
</head>
|
||||
<body>
|
||||
<h1>Books</h1>
|
||||
<input type="search" name="q" id="q" placeholder="Search author or book title..." />
|
||||
<input type="search" name="q" id="q" placeholder="Search author or book title..." autocomplete="off"/>
|
||||
<div>
|
||||
<p>Results for <strong id="query">""</strong></p>
|
||||
<ul id="results">
|
||||
|
@ -23,4 +23,4 @@
|
|||
<script type="text/javascript" src="/api.js"></script>
|
||||
<script type="text/javascript" src="/ui.js"></script>
|
||||
|
||||
</body>
|
||||
</body>
|
|
@ -58,4 +58,3 @@ function refresh()
|
|||
}
|
||||
|
||||
window.setInterval(refresh, 200);
|
||||
|
32
doc/tutorial/test/JavascriptSpec.hs
Normal file
32
doc/tutorial/test/JavascriptSpec.hs
Normal file
|
@ -0,0 +1,32 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module JavascriptSpec where
|
||||
|
||||
import Data.List
|
||||
import Data.String
|
||||
import Data.String.Conversions
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
|
||||
import Javascript
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "apiJS" $ do
|
||||
it "is contained verbatim in Javascript.lhs" $ do
|
||||
code <- readFile "Javascript.lhs"
|
||||
cs apiJS `shouldSatisfy` (`isInfixOf` code)
|
||||
|
||||
describe "writeJSFiles" $ do
|
||||
it "[not a test] write apiJS to static/api.js" $ do
|
||||
writeJSFiles
|
||||
|
||||
describe "app" $ with (return app) $ do
|
||||
context "/api.js" $ do
|
||||
it "delivers apiJS" $ do
|
||||
get "/api.js" `shouldRespondWith` (fromString (cs apiJS))
|
||||
|
||||
context "/" $ do
|
||||
it "delivers something" $ do
|
||||
get "" `shouldRespondWith` 200
|
||||
get "/" `shouldRespondWith` 200
|
1
doc/tutorial/test/Spec.hs
Normal file
1
doc/tutorial/test/Spec.hs
Normal file
|
@ -0,0 +1 @@
|
|||
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
|
13
doc/tutorial/tinc.yaml
Normal file
13
doc/tutorial/tinc.yaml
Normal 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
|
63
doc/tutorial/tutorial.cabal
Normal file
63
doc/tutorial/tutorial.cabal
Normal file
|
@ -0,0 +1,63 @@
|
|||
name: tutorial
|
||||
version: 0.5
|
||||
synopsis: The servant tutorial
|
||||
homepage: http://haskell-servant.github.io/
|
||||
license: BSD3
|
||||
license-file: LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
|
||||
library
|
||||
exposed-modules: ApiType
|
||||
, Client
|
||||
, Docs
|
||||
, Javascript
|
||||
, Server
|
||||
build-depends: base == 4.*
|
||||
, base-compat
|
||||
, text
|
||||
, aeson
|
||||
, aeson-compat
|
||||
, blaze-html
|
||||
, directory
|
||||
, blaze-markup
|
||||
, servant == 0.5.*
|
||||
, servant-server == 0.5.*
|
||||
, servant-client == 0.5.*
|
||||
, servant-docs == 0.5.*
|
||||
, servant-js == 0.5.*
|
||||
, warp
|
||||
, http-media
|
||||
, lucid
|
||||
, time
|
||||
, string-conversions
|
||||
, bytestring
|
||||
, attoparsec
|
||||
, mtl
|
||||
, random
|
||||
, js-jquery
|
||||
, wai
|
||||
, http-types
|
||||
, transformers
|
||||
, markdown-unlit >= 0.4
|
||||
, http-client
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -Werror -pgmL markdown-unlit
|
||||
-- to silence aeson-0.10 warnings:
|
||||
ghc-options: -fno-warn-missing-methods
|
||||
ghc-options: -fno-warn-name-shadowing
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options:
|
||||
-Wall -fno-warn-name-shadowing -fno-warn-missing-signatures
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: test
|
||||
main-is: Spec.hs
|
||||
build-depends: base == 4.*
|
||||
, tutorial
|
||||
, hspec
|
||||
, hspec-wai
|
||||
, string-conversions
|
|
@ -1,2 +0,0 @@
|
|||
import Distribution.Simple
|
||||
main = defaultMain
|
|
@ -1,124 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Data.Aeson hiding ((.:))
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Map (Map, fromList)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import Servant
|
||||
import Servant.Server.Experimental.Auth
|
||||
|
||||
-- | This file contains an authenticated server using servant's generalized
|
||||
-- authentication support. Our basic authentication scheme is trivial: we
|
||||
-- look for a cookie named "servant-auth-cookie" and its value will contain
|
||||
-- a key, which we use to lookup a User. Obviously this is an absurd example,
|
||||
-- but we pick something simple and non-standard to show you how to extend
|
||||
-- servant's support for authentication.
|
||||
|
||||
-- | A user type that we "fetch from the database" after
|
||||
-- performing authentication
|
||||
newtype User = User { unUser :: Text }
|
||||
|
||||
-- | A (pure) database mapping keys to users.
|
||||
database :: Map ByteString User
|
||||
database = fromList [ ("key1", User "Anne Briggs")
|
||||
, ("key2", User "Bruce Cockburn")
|
||||
, ("key3", User "Ghédalia Tazartès")
|
||||
]
|
||||
|
||||
-- | A method that, when given a password, will return a User.
|
||||
-- This is our bespoke (and bad) authentication logic.
|
||||
lookupUser :: ByteString -> ExceptT ServantErr IO User
|
||||
lookupUser key = case Map.lookup key database of
|
||||
Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
|
||||
Just usr -> return usr
|
||||
|
||||
-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
|
||||
-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
|
||||
authHandler :: AuthHandler Request User
|
||||
authHandler =
|
||||
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
|
||||
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
||||
Just authCookieKey -> lookupUser authCookieKey
|
||||
in mkAuthHandler handler
|
||||
|
||||
-- | Data types that will be returned from various api endpoints
|
||||
newtype PrivateData = PrivateData { ssshhh :: Text }
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON PrivateData
|
||||
|
||||
newtype PublicData = PublicData { somedata :: Text }
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance ToJSON PublicData
|
||||
|
||||
-- | Our private API that we want to be auth-protected.
|
||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
||||
|
||||
-- | Our public API that doesn't have any protection
|
||||
type PublicAPI = Get '[JSON] [PublicData]
|
||||
|
||||
-- | Our API, with auth-protection
|
||||
type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
|
||||
:<|> "public" :> PublicAPI
|
||||
|
||||
-- | A value holding our type-level API
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
-- | We need to specify the data returned after authentication
|
||||
type instance AuthServerData (AuthProtect "cookie-auth") = User
|
||||
|
||||
-- | 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.
|
||||
serverContext :: Context (AuthHandler Request User ': '[])
|
||||
serverContext = authHandler :. EmptyContext
|
||||
|
||||
-- | Our API, where we provide all the author-supplied handlers for each end
|
||||
-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
|
||||
-- argument. We dont' worry about the authentication instrumentation here,
|
||||
-- that is taken care of by supplying context
|
||||
server :: Server API
|
||||
server = privateDataFunc :<|> return publicData
|
||||
|
||||
where privateDataFunc (User name) =
|
||||
return [PrivateData ("this is a secret: " <> name)]
|
||||
publicData = [PublicData "this is a public piece of data"]
|
||||
|
||||
-- | run our server
|
||||
main :: IO ()
|
||||
main = run 8080 (serveWithContext api serverContext server)
|
||||
|
||||
{- Sample Session:
|
||||
|
||||
$ curl -XGET localhost:8080/private
|
||||
Missing auth header
|
||||
>>>>>>> modify auth-combinator example for gen auth
|
||||
>>>>>>> 8246c1f... modify auth-combinator example for gen auth
|
||||
|
||||
$ 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"}]
|
||||
-}
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Main where
|
||||
|
||||
import Data.Aeson (ToJSON)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import Servant.API ((:<|>) ((:<|>)), (:>), BasicAuth,
|
||||
Get, JSON)
|
||||
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
|
||||
import Servant.Server (BasicAuthCheck (BasicAuthCheck),
|
||||
BasicAuthResult( Authorized
|
||||
, Unauthorized
|
||||
),
|
||||
Context ((:.), EmptyContext), Server,
|
||||
serveWithContext)
|
||||
|
||||
-- | let's define some types that our API returns.
|
||||
|
||||
-- | 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 API = "public" :> PublicAPI
|
||||
:<|> "private" :> BasicAuth "foo-realm" User :> PrivateAPI
|
||||
|
||||
-- | a value holding a proxy of our API type
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
-- | '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
|
||||
|
||||
-- | 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.
|
||||
serverContext :: Context (BasicAuthCheck User ': '[])
|
||||
serverContext = authCheck :. EmptyContext
|
||||
|
||||
-- | 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.
|
||||
server :: Server API
|
||||
server =
|
||||
let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
|
||||
privateAPIHandler (user :: User) = return (PrivateData (userName user))
|
||||
in publicAPIHandler :<|> privateAPIHandler
|
||||
|
||||
-- | hello, server!
|
||||
main :: IO ()
|
||||
main = run 8080 (serveWithContext api serverContext server)
|
||||
|
||||
{- 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"}
|
||||
-}
|
|
@ -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"
|
|
@ -1,8 +0,0 @@
|
|||
#if __GLASGOW_HASKELL__ >= 710
|
||||
#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
|
||||
#define OVERLAPPING_ {-# OVERLAPPING #-}
|
||||
#else
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
#define OVERLAPPABLE_
|
||||
#define OVERLAPPING_
|
||||
#endif
|
|
@ -1,148 +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: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
copyright: 2015-2016 Servant Contributors
|
||||
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 basic-auth
|
||||
main-is: basic-auth.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: basic-auth
|
||||
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
|
||||
, containers
|
||||
, http-types
|
||||
, servant == 0.5.*
|
||||
, servant-server == 0.5.*
|
||||
, text
|
||||
, transformers
|
||||
, 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
|
|
@ -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)
|
||||
|
|
@ -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>
|
|
@ -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 — ";
|
||||
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);
|
||||
});
|
||||
});
|
|
@ -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%;
|
||||
}
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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'
|
|
@ -1,4 +0,0 @@
|
|||
import T8
|
||||
|
||||
main :: IO ()
|
||||
main = run
|
|
@ -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."
|
|
@ -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 -> Context context -> 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
|
|
@ -5,7 +5,7 @@ servant-docs
|
|||
servant-foreign
|
||||
servant-js
|
||||
servant-server
|
||||
servant-examples
|
||||
servant-blaze
|
||||
servant-lucid
|
||||
servant-mock
|
||||
doc/tutorial
|
||||
|
|
|
@ -7,15 +7,18 @@ packages:
|
|||
- servant-cassava/
|
||||
- servant-client/
|
||||
- servant-docs/
|
||||
- servant-examples/
|
||||
- servant-foreign/
|
||||
- servant-js/
|
||||
- servant-lucid/
|
||||
- servant-mock/
|
||||
- servant-server/
|
||||
- doc/tutorial
|
||||
extra-deps:
|
||||
- base-compat-0.9.0
|
||||
- engine-io-wai-1.0.2
|
||||
- control-monad-omega-0.3.1
|
||||
- should-not-typecheck-2.0.1
|
||||
resolver: nightly-2015-10-08
|
||||
- markdown-unlit-0.4.0
|
||||
- aeson-0.11.0.0
|
||||
- fail-4.9.0.0
|
||||
resolver: nightly-2016-03-17
|
||||
|
|
Loading…
Reference in a new issue