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

Merge pull request #355 from haskell-servant/tutorial

Browse source 
Tutorial
This commit is contained in:
Julian Arni 2016-03-19 12:04:51 +01:00
commit eb11fe6b02
50 changed files with 2828 additions and 1767 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
.gitignore vendored
View file

@ -25,3 +25,7 @@ Setup
.stack-work .stack-work
shell.nix shell.nix
default.nix default.nix
doc/_build
doc/venv
doc/tutorial/static/api.js
doc/tutorial/static/jq.js

216
doc/Makefile Normal file
View file

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

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

@ -0,0 +1,8 @@
To build the docs locally:
$ virtualenv venv
$ . ./venv/bin/activate
$ pip install -r requirements.txt
$ make html
Docs will be built in _build/html/index.html .

294
doc/conf.py Normal file
View file

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

22
doc/index.rst Normal file
View file

@ -0,0 +1,22 @@
servant – A Type-Level Web DSL
==============================
.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png
**servant** is a set of packages for declaring web APIs at the type-level and
then using those API specifications to:
- write servers (this part of **servant** can be considered a web framework),
- obtain client functions (in haskell),
- generate client functions for other programming languages,
- generate documentation for your web applications
- and more...
All in a type-safe manner.
.. toctree::
:maxdepth: 2
introduction.rst
tutorial/index.rst
links.rst

40
doc/introduction.rst Normal file
View file

@ -0,0 +1,40 @@
Introduction
------------
**servant** has the following guiding principles:
- concision
This is a pretty wide-ranging principle. You should be able to get nice
documentation for your web servers, and client libraries, without repeating
yourself. You should not have to manually serialize and deserialize your
resources, but only declare how to do those things *once per type*. If a
bunch of your handlers take the same query parameters, you shouldn't have to
repeat that logic for each handler, but instead just "apply" it to all of
them at once. Your handlers shouldn't be where composition goes to die. And
so on.
- flexibility
If we haven't thought of your use case, it should still be easily
achievable. If you want to use templating library X, go ahead. Forms? Do
them however you want, but without difficulty. We're not opinionated.
- separation of concerns
Your handlers and your HTTP logic should be separate. True to the philosphy
at the core of HTTP and REST, with **servant** your handlers return normal
Haskell datatypes - that's the resource. And then from a description of your
API, **servant** handles the *presentation* (i.e., the Content-Types). But
that's just one example.
- type safety
Want to be sure your API meets a specification? Your compiler can check
that for you. Links you can be sure exist? You got it.
To stick true to these principles, we do things a little differently than you
might expect. The core idea is *reifying the description of your API*. Once
reified, everything follows. We think we might be the first web framework to
reify API descriptions in an extensible way. We're pretty sure we're the first
to reify it as *types*.

34
doc/links.rst Normal file
View file

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

25
doc/requirements.txt Normal file
View file

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

1
doc/tutorial/.ghci Normal file
View file

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

311
doc/tutorial/ApiType.lhs Normal file
View 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&param=value2`. This represents a list of values
composed of `value1` and `value2`. `QueryFlag` lets you specify a
boolean-like query parameter where a client isn't forced to specify a
value. The absence or presence of the parameter's name in the query
string determines whether the parameter is considered to have the
value `True` or `False`. For instance, `/users?active` would list only
active users whereas `/users` would list them all.
Here are the corresponding data type declarations:
``` haskell ignore
data QueryParam (sym :: Symbol) a
data QueryParams (sym :: Symbol) a
data QueryFlag (sym :: Symbol)
```
Examples:
``` haskell
type UserAPI6 = "users" :> QueryParam "sortby" SortBy :> Get '[JSON] [User]
-- equivalent to 'GET /users?sortby={age, name}'
```
Again, your handlers don't have to deserialize these things (into, for example,
a `SortBy`). **servant** takes care of it.
### `ReqBody`
Each HTTP request can carry some additional data that the server can use in its
*body*, and this data can be encoded in any format -- as long as the server
understands it. This can be used for example for an endpoint for creating new
users: instead of passing each field of the user as a separate query string
parameter or something dirty like that, we can group all the data into a JSON
object. This has the advantage of supporting nested objects.
**servant**'s `ReqBody` combinator takes a list of content types in which the
data encoded in the request body can be represented and the type of that data.
And, as you might have guessed, you don't have to check the content type
header, and do the deserialization yourself. We do it for you. And return `Bad
Request` or `Unsupported Content Type` as appropriate.
Here's the data type declaration for it:
``` haskell ignore
data ReqBody (contentTypes :: [*]) a
```
Examples:
``` haskell
type UserAPI7 = "users" :> ReqBody '[JSON] User :> Post '[JSON] User
-- - equivalent to 'POST /users' with a JSON object
-- describing a User in the request body
-- - returns a User encoded in JSON
:<|> "users" :> Capture "userid" Integer
:> ReqBody '[JSON] User
:> Put '[JSON] User
-- - equivalent to 'PUT /users/:userid' with a JSON
-- object describing a User in the request body
-- - returns a User encoded in JSON
```
### Request `Header`s
Request headers are used for various purposes, from caching to carrying
auth-related data. They consist of a header name and an associated value. An
example would be `Accept: application/json`.
The `Header` combinator in **servant** takes a type-level string for the header
name and the type to which we want to decode the header's value (from some
textual representation), as illustrated below:
``` haskell ignore
data Header (sym :: Symbol) a
```
Here's an example where we declare that an endpoint makes use of the
`User-Agent` header which specifies the name of the software/library used by
the client to send the request.
``` haskell
type UserAPI8 = "users" :> Header "User-Agent" Text :> Get '[JSON] [User]
```
### Content types
So far, whenever we have used a combinator that carries a list of content
types, we've always specified `'[JSON]`. However, **servant** lets you use several
content types, and also lets you define your own content types.
Four content types are provided out-of-the-box by the core **servant** package:
`JSON`, `PlainText`, `FormUrlEncoded` and `OctetStream`. If for some obscure
reason you wanted one of your endpoints to make your user data available under
those 4 formats, you would write the API type as below:
``` haskell
type UserAPI9 = "users" :> Get '[JSON, PlainText, FormUrlEncoded, OctetStream] [User]
```
(There are other packages that provide other content types. For example
**servant-lucid** and **servant-blaze** allow to generate html pages (using
**lucid** and **blaze-html**) and both come with a content type for html.)
We will further explain how these content types and your data types can play
together in the [section about serving an API](Server.html).
### Response `Headers`
Just like an HTTP request, the response generated by a webserver can carry
headers too. **servant** provides a `Headers` combinator that carries a list of
`Header` types and can be used by simply wrapping the "return type" of an endpoint
with it.
``` haskell ignore
data Headers (ls :: [*]) a
```
If you want to describe an endpoint that returns a "User-Count" header in each
response, you could write it as below:
``` haskell
type UserAPI10 = "users" :> Get '[JSON] (Headers '[Header "User-Count" Integer] [User])
```
### 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
View 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
View file

@ -0,0 +1,234 @@
# Documenting an API
The source for this tutorial section is a literate haskell file, so first we
need to have some language extensions and imports:
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Docs where
import Data.ByteString.Lazy (ByteString)
import Data.Proxy
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Text.Lazy (pack)
import Network.HTTP.Types
import Network.Wai
import Servant.API
import Servant.Docs
import Servant.Server
```
And we'll import some things from one of our earlier modules
([Serving an API](Server.html)):
``` haskell
import Server (Email(..), ClientInfo(..), Position(..), HelloMessage(..),
server3, emailForClient)
```
Like client function generation, documentation generation amounts to inspecting the API type and extracting all the data we need to then present it in some format to users of your API.
This time however, we have to assist **servant**. While it is able to deduce a lot of things about our API, it can't magically come up with descriptions of the various pieces of our APIs that are human-friendly and explain what's going on "at the business-logic level". A good example to study for documentation generation is our webservice with the `/position`, `/hello` and `/marketing` endpoints from earlier:
``` haskell
type ExampleAPI = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position
:<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage
:<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email
exampleAPI :: Proxy ExampleAPI
exampleAPI = Proxy
```
While **servant** can see e.g. that there are 3 endpoints and that the response bodies will be in JSON, it doesn't know what influence the captures, parameters, request bodies and other combinators have on the webservice. This is where some manual work is required.
For every capture, request body, response body, query param, we have to give some explanations about how it influences the response, what values are possible and the likes. Here's how it looks like for the parameters we have above.
``` haskell
instance ToCapture (Capture "x" Int) where
toCapture _ =
DocCapture "x" -- name
"(integer) position on the x axis" -- description
instance ToCapture (Capture "y" Int) where
toCapture _ =
DocCapture "y" -- name
"(integer) position on the y axis" -- description
instance ToSample Position where
toSamples _ = singleSample (Position 3 14) -- example of output
instance ToParam (QueryParam "name" String) where
toParam _ =
DocQueryParam "name" -- name
["Alp", "John Doe", "..."] -- example of values (not necessarily exhaustive)
"Name of the person to say hello to." -- description
Normal -- Normal, List or Flag
instance ToSample HelloMessage where
toSamples _ =
[ ("When a value is provided for 'name'", HelloMessage "Hello, Alp")
, ("When 'name' is not specified", HelloMessage "Hello, anonymous coward")
]
-- mutliple examples to display this time
ci :: ClientInfo
ci = ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
instance ToSample ClientInfo where
toSamples _ = singleSample ci
instance ToSample Email where
toSamples _ = singleSample (emailForClient ci)
```
Types that are used as request or response bodies have to instantiate the `ToSample` typeclass which lets you specify one or more examples of values. `Capture`s and `QueryParam`s have to instantiate their respective `ToCapture` and `ToParam` classes and provide a name and some information about the concrete meaning of that argument, as illustrated in the code above.
With all of this, we can derive docs for our API.
``` haskell
apiDocs :: API
apiDocs = docs exampleAPI
```
`API` is a type provided by **servant-docs** that stores all the information one needs about a web API in order to generate documentation in some format. Out of the box, **servant-docs** only provides a pretty documentation printer that outputs [Markdown](http://en.wikipedia.org/wiki/Markdown), but the [**servant-pandoc**](http://hackage.haskell.org/package/servant-pandoc) package can be used to target many useful formats.
**servant**'s markdown pretty printer is a function named `markdown`.
``` haskell ignore
markdown :: API -> String
```
That lets us see what our API docs look down in markdown, by looking at `markdown apiDocs`.
````````` text
## Welcome
This is our super webservice's API.
Enjoy!
## GET /hello
#### GET Parameters:
- name
- **Values**: *Alp, John Doe, ...*
- **Description**: Name of the person to say hello to.
#### Response:
- Status code 200
- Headers: []
- Supported content types are:
- `application/json`
- When a value is provided for 'name'
```javascript
{"msg":"Hello, Alp"}
```
- When 'name' is not specified
```javascript
{"msg":"Hello, anonymous coward"}
```
## POST /marketing
#### Request:
- Supported content types are:
- `application/json`
- Example: `application/json`
```javascript
{"email":"alp@foo.com","interested_in":["haskell","mathematics"],"age":26,"name":"Alp"}
```
#### Response:
- Status code 201
- Headers: []
- Supported content types are:
- `application/json`
- Response body as below.
```javascript
{"subject":"Hey Alp, we miss you!","body":"Hi Alp,\n\nSince you've recently turned 26, have you checked out our latest haskell, mathematics products? Give us a visit!","to":"alp@foo.com","from":"great@company.com"}
```
## GET /position/:x/:y
#### Captures:
- *x*: (integer) position on the x axis
- *y*: (integer) position on the y axis
#### Response:
- Status code 200
- Headers: []
- Supported content types are:
- `application/json`
- Response body as below.
```javascript
{"x":3,"y":14}
```
`````````
However, we can also add one or more introduction sections to the document. We just need to tweak the way we generate `apiDocs`. We will also convert the content to a lazy `ByteString` since this is what **wai** expects for `Raw` endpoints.
``` haskell
docsBS :: ByteString
docsBS = encodeUtf8
. pack
. markdown
$ docsWithIntros [intro] exampleAPI
where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"]
```
`docsWithIntros` just takes an additional parameter, a list of `DocIntro`s that must be displayed before any endpoint docs.
We can now serve the API *and* the API docs with a simple server.
``` haskell
type DocsAPI = ExampleAPI :<|> Raw
api :: Proxy DocsAPI
api = Proxy
server :: Server DocsAPI
server = Server.server3 :<|> serveDocs
where serveDocs _ respond =
respond $ responseLBS ok200 [plain] docsBS
plain = ("Content-Type", "text/plain")
app :: Application
app = serve api server
```
And if you spin up this server and request anything else than `/position`, `/hello` and `/marketing`, you will see the API docs in markdown. This is because `serveDocs` is attempted if the 3 other endpoints don't match and systematically succeeds since its definition is to just return some fixed bytestring with the `text/plain` content type.

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

@ -0,0 +1,228 @@
# Generating Javascript functions to query an API
We will now see how **servant** lets you turn an API type into javascript
functions that you can call to query a webservice.
For this, we will consider a simple page divided in two parts. At the top, we
will have a search box that lets us search in a list of Haskell books by
author/title with a list of results that gets updated every time we enter or
remove a character, while at the bottom we will be able to see the classical
[probabilistic method to approximate
pi](http://en.wikipedia.org/wiki/Approximations_of_%CF%80#Summing_a_circle.27s_area),
using a webservice to get random points. Finally, we will serve an HTML file
along with a couple of Javascript files, among which one that's automatically
generated from the API type and which will provide ready-to-use functions to
query your API.
The source for this tutorial section is a literate haskell file, so first we
need to have some language extensions and imports:
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Javascript where
import Control.Monad.IO.Class
import Data.Aeson
import Data.Proxy
import Data.Text as T (Text)
import Data.Text.IO as T (writeFile, readFile)
import GHC.Generics
import Language.Javascript.JQuery
import Network.Wai
import Network.Wai.Handler.Warp
import qualified Data.Text as T
import Servant
import Servant.JS
import System.Random
```
Now let's have the API type(s) and the accompanying datatypes.
``` haskell
type API = "point" :> Get '[JSON] Point
:<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book)
type API' = API :<|> Raw
data Point = Point
{ x :: Double
, y :: Double
} deriving Generic
instance ToJSON Point
data Search a = Search
{ query :: Text
, results :: [a]
} deriving Generic
mkSearch :: Text -> [a] -> Search a
mkSearch = Search
instance ToJSON a => ToJSON (Search a)
data Book = Book
{ author :: Text
, title :: Text
, year :: Int
} deriving Generic
instance ToJSON Book
book :: Text -> Text -> Int -> Book
book = Book
```
We need a "book database". For the purpose of this guide, let's restrict
ourselves to the following books.
``` haskell
books :: [Book]
books =
[ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000
, book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008
, book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011
, book "Graham Hutton" "Programming in Haskell" 2007
, book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013
, book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998
]
```
Now, given an optional search string `q`, we want to perform a case insensitive
search in that list of books. We're obviously not going to try and implement
the best possible algorithm, this is out of scope for this tutorial. The
following simple linear scan will do, given how small our list is.
``` haskell
searchBook :: Monad m => Maybe Text -> m (Search Book)
searchBook Nothing = return (mkSearch "" books)
searchBook (Just q) = return (mkSearch q books')
where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b)
|| q' `T.isInfixOf` T.toLower (title b)
)
books
q' = T.toLower q
```
We also need an endpoint that generates random points `(x, y)` with `-1 <= x,y
<= 1`. The code below uses
[random](http://hackage.haskell.org/package/random)'s `System.Random`.
``` haskell
randomPoint :: MonadIO m => m Point
randomPoint = liftIO . getStdRandom $ \g ->
let (rx, g') = randomR (-1, 1) g
(ry, g'') = randomR (-1, 1) g'
in (Point rx ry, g'')
```
If we add static file serving, our server is now complete.
``` haskell
api :: Proxy API
api = Proxy
api' :: Proxy API'
api' = Proxy
server :: Server API
server = randomPoint
:<|> searchBook
server' :: Server API'
server' = server
:<|> serveDirectory "static"
app :: Application
app = serve api' server'
main :: IO ()
main = run 8000 app
```
Why two different API types, proxies and servers though? Simply because we
don't want to generate javascript functions for the `Raw` part of our API type,
so we need a `Proxy` for our API type `API'` without its `Raw` endpoint.
Very similarly to how one can derive haskell functions, we can derive the
javascript with just a simple function call to `jsForAPI` from
`Servant.JQuery`.
``` haskell
apiJS :: Text
apiJS = jsForAPI api vanillaJS
```
This `Text` contains 2 Javascript functions, 'getPoint' and 'getBooks':
``` javascript
var getPoint = function(onSuccess, onError)
{
var xhr = new XMLHttpRequest();
xhr.open('GET', '/point', true);
xhr.setRequestHeader("Accept","application/json");
xhr.onreadystatechange = function (e) {
if (xhr.readyState == 4) {
if (xhr.status == 204 || xhr.status == 205) {
onSuccess();
} else if (xhr.status >= 200 && xhr.status < 300) {
var value = JSON.parse(xhr.responseText);
onSuccess(value);
} else {
var value = JSON.parse(xhr.responseText);
onError(value);
}
}
}
xhr.send(null);
}
var getBooks = function(q, onSuccess, onError)
{
var xhr = new XMLHttpRequest();
xhr.open('GET', '/books' + '?q=' + encodeURIComponent(q), true);
xhr.setRequestHeader("Accept","application/json");
xhr.onreadystatechange = function (e) {
if (xhr.readyState == 4) {
if (xhr.status == 204 || xhr.status == 205) {
onSuccess();
} else if (xhr.status >= 200 && xhr.status < 300) {
var value = JSON.parse(xhr.responseText);
onSuccess(value);
} else {
var value = JSON.parse(xhr.responseText);
onError(value);
}
}
}
xhr.send(null);
}
```
We created a directory `static` that contains two static files: `index.html`,
which is the entrypoint to our little web application; and `ui.js`, which
contains some hand-written javascript. This javascript code assumes the two
generated functions `getPoint` and `getBooks` in scope. Therefore we need to
write the generated javascript into a file:
``` haskell
writeJSFiles :: IO ()
writeJSFiles = do
T.writeFile "static/api.js" apiJS
jq <- T.readFile =<< Language.Javascript.JQuery.file
T.writeFile "static/jq.js" jq
```
(We're also writing the jquery library into a file, as it's also used by
`ui.js`.) `static/api.js` will be included in `index.html` and the two
generated functions will therefore be available in `ui.js`.
And we're good to go. You can start the `main` function of this file and go to
`http://localhost:8000/`. Start typing in the name of one of the authors in our
database or part of a book title, and check out how long it takes to
approximate pi using the method mentioned above.

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

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

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

File diff suppressed because it is too large Load diff

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

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

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

@ -0,0 +1,18 @@
Tutorial
========
This is an introductory tutorial to **servant**.
(Any comments, issues or feedback about the tutorial can be 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

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

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

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

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

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

@ -0,0 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
module JavascriptSpec where
import Data.List
import Data.String
import Data.String.Conversions
import Test.Hspec
import Test.Hspec.Wai
import Javascript
spec :: Spec
spec = do
describe "apiJS" $ do
it "is contained verbatim in Javascript.lhs" $ do
code <- readFile "Javascript.lhs"
cs apiJS `shouldSatisfy` (`isInfixOf` code)
describe "writeJSFiles" $ do
it "[not a test] write apiJS to static/api.js" $ do
writeJSFiles
describe "app" $ with (return app) $ do
context "/api.js" $ do
it "delivers apiJS" $ do
get "/api.js" `shouldRespondWith` (fromString (cs apiJS))
context "/" $ do
it "delivers something" $ do
get "" `shouldRespondWith` 200
get "/" `shouldRespondWith` 200

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

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

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

@ -0,0 +1,13 @@
dependencies:
- name: servant
path: ../../servant
- name: servant-server
path: ../../servant-server
- name: servant-client
path: ../../servant-client
- name: servant-js
path: ../../servant-js
- name: servant-docs
path: ../../servant-docs
- name: servant-foreign
path: ../../servant-foreign

63
doc/tutorial/tutorial.cabal Normal file
View 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

2
servant-examples/Setup.hs
View file

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

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

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

105
servant-examples/basic-auth/basic-auth.hs
View file

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

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

@ -1,90 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson
import Data.Monoid
import Data.Proxy
import Data.Text (Text)
import GHC.Generics
import Network.HTTP.Client (Manager, defaultManagerSettings,
newManager)
import System.IO.Unsafe (unsafePerformIO)
import Servant.API
import Servant.Client
import qualified Data.Text as T
import qualified Data.Text.IO as T
type HackageAPI =
"users" :> Get '[JSON] [UserSummary]
:<|> "user" :> Capture "username" Username :> Get '[JSON] UserDetailed
:<|> "packages" :> Get '[JSON] [Package]
type Username = Text
data UserSummary = UserSummary
{ summaryUsername :: Username
, summaryUserid :: Int
} deriving (Eq, Show)
instance FromJSON UserSummary where
parseJSON (Object o) =
UserSummary <$> o .: "username"
<*> o .: "userid"
parseJSON _ = mzero
type Group = Text
data UserDetailed = UserDetailed
{ username :: Username
, userid :: Int
, groups :: [Group]
} deriving (Eq, Show, Generic)
instance FromJSON UserDetailed
newtype Package = Package { packageName :: Text }
deriving (Eq, Show, Generic)
instance FromJSON Package
hackageAPI :: Proxy HackageAPI
hackageAPI = Proxy
{-# NOINLINE manager #-}
manager :: Manager
manager = unsafePerformIO $ newManager defaultManagerSettings
getUsers :: ExceptT ServantError IO [UserSummary]
getUser :: Username -> ExceptT ServantError IO UserDetailed
getPackages :: ExceptT ServantError IO [Package]
getUsers :<|> getUser :<|> getPackages =
client hackageAPI (BaseUrl Http "hackage.haskell.org" 80 "") manager
main :: IO ()
main = print =<< uselessNumbers
uselessNumbers :: IO (Either ServantError ())
uselessNumbers = runExceptT $ do
users <- getUsers
liftIO . putStrLn $ show (length users) ++ " users"
user <- liftIO $ do
putStrLn "Enter a valid hackage username"
T.getLine
userDetailed <- getUser user
liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"
packages <- getPackages
let monadPackages = filter (isMonadPackage . packageName) packages
liftIO . putStrLn $ show (length monadPackages) ++ " monad packages"
where isMonadPackage = T.isInfixOf "monad"

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

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

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

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

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

@ -1,109 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
module Chat (eioServer, ServerState (..)) where
import Prelude hiding (mapM_)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), pure)
#endif
import Control.Monad.State.Class (MonadState)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson ((.=))
import Data.Foldable (mapM_)
import qualified Control.Concurrent.STM as STM
import qualified Data.Aeson as Aeson
import qualified Data.Text as Text
import qualified Network.SocketIO as SocketIO
data AddUser = AddUser Text.Text
instance Aeson.FromJSON AddUser where
parseJSON = Aeson.withText "AddUser" $ pure . AddUser
data NumConnected = NumConnected !Int
instance Aeson.ToJSON NumConnected where
toJSON (NumConnected n) = Aeson.object [ "numUsers" .= n]
data NewMessage = NewMessage Text.Text
instance Aeson.FromJSON NewMessage where
parseJSON = Aeson.withText "NewMessage" $ pure . NewMessage
data Said = Said Text.Text Text.Text
instance Aeson.ToJSON Said where
toJSON (Said username message) = Aeson.object
[ "username" .= username
, "message" .= message
]
data UserName = UserName Text.Text
instance Aeson.ToJSON UserName where
toJSON (UserName un) = Aeson.object [ "username" .= un ]
data UserJoined = UserJoined Text.Text Int
instance Aeson.ToJSON UserJoined where
toJSON (UserJoined un n) = Aeson.object
[ "username" .= un
, "numUsers" .= n
]
--------------------------------------------------------------------------------
data ServerState = ServerState { ssNConnected :: STM.TVar Int }
--server :: ServerState -> StateT SocketIO.RoutingTable Snap.Snap ()
eioServer :: forall (m :: * -> *). (MonadState SocketIO.RoutingTable m, MonadIO m) => ServerState -> m ()
eioServer state = do
userNameMVar <- liftIO STM.newEmptyTMVarIO
let forUserName m = liftIO (STM.atomically (STM.tryReadTMVar userNameMVar)) >>= mapM_ m
SocketIO.on "new message" $ \(NewMessage message) ->
forUserName $ \userName ->
SocketIO.broadcast "new message" (Said userName message)
SocketIO.on "add user" $ \(AddUser userName) -> do
n <- liftIO $ STM.atomically $ do
n <- (+ 1) <$> STM.readTVar (ssNConnected state)
STM.putTMVar userNameMVar userName
STM.writeTVar (ssNConnected state) n
return n
SocketIO.emit "login" (NumConnected n)
SocketIO.broadcast "user joined" (UserJoined userName n)
SocketIO.appendDisconnectHandler $ do
(n, mUserName) <- liftIO $ STM.atomically $ do
n <- (+ (-1)) <$> STM.readTVar (ssNConnected state)
mUserName <- STM.tryReadTMVar userNameMVar
STM.writeTVar (ssNConnected state) n
return (n, mUserName)
case mUserName of
Nothing -> return ()
Just userName ->
SocketIO.broadcast "user left" (UserJoined userName n)
SocketIO.on "typing" $
forUserName $ \userName ->
SocketIO.broadcast "typing" (UserName userName)
SocketIO.on "stop typing" $
forUserName $ \userName ->
SocketIO.broadcast "stop typing" (UserName userName)

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

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

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

@ -1,274 +0,0 @@
$(function() {
var FADE_TIME = 150; // ms
var TYPING_TIMER_LENGTH = 400; // ms
var COLORS = [
'#e21400', '#91580f', '#f8a700', '#f78b00',
'#58dc00', '#287b00', '#a8f07a', '#4ae8c4',
'#3b88eb', '#3824aa', '#a700ff', '#d300e7'
];
// Initialize varibles
var $window = $(window);
var $usernameInput = $('.usernameInput'); // Input for username
var $messages = $('.messages'); // Messages area
var $inputMessage = $('.inputMessage'); // Input message input box
var $loginPage = $('.login.page'); // The login page
var $chatPage = $('.chat.page'); // The chatroom page
// Prompt for setting a username
var username;
var connected = false;
var typing = false;
var lastTypingTime;
var $currentInput = $usernameInput.focus();
var socket = io();
function addParticipantsMessage (data) {
var message = '';
if (data.numUsers === 1) {
message += "there's 1 participant";
} else {
message += "there're " + data.numUsers + " participants";
}
log(message);
}
// Sets the client's username
function setUsername () {
username = cleanInput($usernameInput.val().trim());
// If the username is valid
if (username) {
$loginPage.fadeOut();
$chatPage.show();
$loginPage.off('click');
$currentInput = $inputMessage.focus();
// Tell the server your username
socket.emit('add user', username);
}
}
// Sends a chat message
function sendMessage () {
var message = $inputMessage.val();
// Prevent markup from being injected into the message
message = cleanInput(message);
// if there is a non-empty message and a socket connection
if (message && connected) {
$inputMessage.val('');
addChatMessage({
username: username,
message: message
});
// tell server to execute 'new message' and send along one parameter
socket.emit('new message', message);
}
}
// Log a message
function log (message, options) {
var $el = $('<li>').addClass('log').text(message);
addMessageElement($el, options);
}
// Adds the visual chat message to the message list
function addChatMessage (data, options) {
// Don't fade the message in if there is an 'X was typing'
var $typingMessages = getTypingMessages(data);
options = options || {};
if ($typingMessages.length !== 0) {
options.fade = false;
$typingMessages.remove();
}
var $usernameDiv = $('<span class="username"/>')
.text(data.username)
.css('color', getUsernameColor(data.username));
var $messageBodyDiv = $('<span class="messageBody">')
.text(data.message);
var typingClass = data.typing ? 'typing' : '';
var $messageDiv = $('<li class="message"/>')
.data('username', data.username)
.addClass(typingClass)
.append($usernameDiv, $messageBodyDiv);
addMessageElement($messageDiv, options);
}
// Adds the visual chat typing message
function addChatTyping (data) {
data.typing = true;
data.message = 'is typing';
addChatMessage(data);
}
// Removes the visual chat typing message
function removeChatTyping (data) {
getTypingMessages(data).fadeOut(function () {
$(this).remove();
});
}
// Adds a message element to the messages and scrolls to the bottom
// el - The element to add as a message
// options.fade - If the element should fade-in (default = true)
// options.prepend - If the element should prepend
// all other messages (default = false)
function addMessageElement (el, options) {
var $el = $(el);
// Setup default options
if (!options) {
options = {};
}
if (typeof options.fade === 'undefined') {
options.fade = true;
}
if (typeof options.prepend === 'undefined') {
options.prepend = false;
}
// Apply options
if (options.fade) {
$el.hide().fadeIn(FADE_TIME);
}
if (options.prepend) {
$messages.prepend($el);
} else {
$messages.append($el);
}
$messages[0].scrollTop = $messages[0].scrollHeight;
}
// Prevents input from having injected markup
function cleanInput (input) {
return $('<div/>').text(input).text();
}
// Updates the typing event
function updateTyping () {
if (connected) {
if (!typing) {
typing = true;
socket.emit('typing');
}
lastTypingTime = (new Date()).getTime();
setTimeout(function () {
var typingTimer = (new Date()).getTime();
var timeDiff = typingTimer - lastTypingTime;
if (timeDiff >= TYPING_TIMER_LENGTH && typing) {
socket.emit('stop typing');
typing = false;
}
}, TYPING_TIMER_LENGTH);
}
}
// Gets the 'X is typing' messages of a user
function getTypingMessages (data) {
return $('.typing.message').filter(function (i) {
return $(this).data('username') === data.username;
});
}
// Gets the color of a username through our hash function
function getUsernameColor (username) {
// Compute hash code
var hash = 7;
for (var i = 0; i < username.length; i++) {
hash = username.charCodeAt(i) + (hash << 5) - hash;
}
// Calculate color
var index = Math.abs(hash % COLORS.length);
return COLORS[index];
}
// Keyboard events
$window.keydown(function (event) {
// Auto-focus the current input when a key is typed
if (!(event.ctrlKey || event.metaKey || event.altKey)) {
$currentInput.focus();
}
// When the client hits ENTER on their keyboard
if (event.which === 13) {
if (username) {
sendMessage();
socket.emit('stop typing');
typing = false;
} else {
setUsername();
}
}
});
$inputMessage.on('input', function() {
updateTyping();
});
// Click events
// Focus input when clicking anywhere on login page
$loginPage.click(function () {
$currentInput.focus();
});
// Focus input when clicking on the message input's border
$inputMessage.click(function () {
$inputMessage.focus();
});
// Socket events
socket.on('connected', function (data) {
console.log('connected:', data);
});
// Socket events
socket.on('changes', function (data) {
console.log('changes:', data);
});
// Whenever the server emits 'login', log the login message
socket.on('login', function (data) {
connected = true;
// Display the welcome message
var message = "Welcome to Socket.IO Chat &mdash; ";
log(message, {
prepend: true
});
addParticipantsMessage(data);
});
// Whenever the server emits 'new message', update the chat body
socket.on('new message', function (data) {
addChatMessage(data);
});
// Whenever the server emits 'user joined', log it in the chat body
socket.on('user joined', function (data) {
log(data.username + ' joined');
addParticipantsMessage(data);
});
// Whenever the server emits 'user left', log it in the chat body
socket.on('user left', function (data) {
log(data.username + ' left');
addParticipantsMessage(data);
removeChatTyping(data);
});
// Whenever the server emits 'typing', show the typing message
socket.on('typing', function (data) {
addChatTyping(data);
});
// Whenever the server emits 'stop typing', kill the typing message
socket.on('stop typing', function (data) {
removeChatTyping(data);
});
});

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

@ -1,150 +0,0 @@
/* Fix user-agent */
* {
box-sizing: border-box;
}
html {
font-weight: 300;
-webkit-font-smoothing: antialiased;
}
html, input {
font-family:
"HelveticaNeue-Light",
"Helvetica Neue Light",
"Helvetica Neue",
Helvetica,
Arial,
"Lucida Grande",
sans-serif;
}
html, body {
height: 100%;
margin: 0;
padding: 0;
}
ul {
list-style: none;
word-wrap: break-word;
}
/* Pages */
.pages {
height: 100%;
margin: 0;
padding: 0;
width: 100%;
}
.page {
height: 100%;
position: absolute;
width: 100%;
}
/* Login Page */
.login.page {
background-color: #000;
}
.login.page .form {
height: 100px;
margin-top: -100px;
position: absolute;
text-align: center;
top: 50%;
width: 100%;
}
.login.page .form .usernameInput {
background-color: transparent;
border: none;
border-bottom: 2px solid #fff;
outline: none;
padding-bottom: 15px;
text-align: center;
width: 400px;
}
.login.page .title {
font-size: 200%;
}
.login.page .usernameInput {
font-size: 200%;
letter-spacing: 3px;
}
.login.page .title, .login.page .usernameInput {
color: #fff;
font-weight: 100;
}
/* Chat page */
.chat.page {
display: none;
}
/* Font */
.messages {
font-size: 150%;
}
.inputMessage {
font-size: 100%;
}
.log {
color: gray;
font-size: 70%;
margin: 5px;
text-align: center;
}
/* Messages */
.chatArea {
height: 100%;
padding-bottom: 60px;
}
.messages {
height: 100%;
margin: 0;
overflow-y: scroll;
padding: 10px 20px 10px 20px;
}
.message.typing .messageBody {
color: gray;
}
.username {
float: left;
font-weight: 700;
overflow: hidden;
padding-right: 15px;
text-align: right;
}
/* Input */
.inputMessage {
border: 10px solid #000;
bottom: 0;
height: 60px;
left: 0;
outline: none;
padding-left: 10px;
position: absolute;
right: 0;
width: 100%;
}

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

@ -1,54 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import Data.Monoid ((<>))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Network.EngineIO.Wai
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Servant
import qualified Control.Concurrent.STM as STM
import qualified Network.SocketIO as SocketIO
import Chat (ServerState (..), eioServer)
type API = "socket.io" :> Raw
:<|> Raw
api :: Proxy API
api = Proxy
server :: WaiMonad () -> Server API
server sHandler = socketIOHandler
:<|> serveDirectory "socket-io-chat/resources"
where
socketIOHandler req respond = toWaiApplication sHandler req respond
app :: WaiMonad () -> Application
app sHandler = serve api $ server sHandler
port :: Int
port = 3001
main :: IO ()
main = do
state <- ServerState <$> STM.newTVarIO 0
sHandler <- SocketIO.initialize waiAPI (eioServer state)
putStrLn $ "Running on " <> show port
run port $ app sHandler

15
servant-examples/tinc.yaml
View file

@ -1,15 +0,0 @@
dependencies:
- name: servant
path: ../servant
- name: servant-server
path: ../servant-server
- name: servant-client
path: ../servant-client
- name: servant-js
path: ../servant-js
- name: servant-lucid
path: ../servant-lucid
- name: servant-docs
path: ../servant-docs
- name: servant-foreign
path: ../servant-foreign

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

@ -1,45 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T1 where
import Data.Aeson
import Data.Time.Calendar
import GHC.Generics
import Network.Wai
import Servant
data User = User
{ name :: String
, age :: Int
, email :: String
, registration_date :: Day
} deriving (Eq, Show, Generic)
#if !MIN_VERSION_aeson(0,10,0)
-- orphan ToJSON instance for Day. necessary to derive one for User
instance ToJSON Day where
-- display a day in YYYY-mm-dd format
toJSON d = toJSON (showGregorian d)
#endif
instance ToJSON User
type UserAPI = "users" :> Get '[JSON] [User]
users :: [User]
users =
[ User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1)
, User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1)
]
userAPI :: Proxy UserAPI
userAPI = Proxy
server :: Server UserAPI
server = return users
app :: Application
app = serve userAPI server

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

@ -1,71 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T10 where
import Data.ByteString.Lazy (ByteString)
import Data.Text.Lazy (pack)
import Data.Text.Lazy.Encoding (encodeUtf8)
import Network.HTTP.Types
import Network.Wai
import Servant
import Servant.Docs
import qualified T3
type DocsAPI = T3.API :<|> Raw
instance ToCapture (Capture "x" Int) where
toCapture _ = DocCapture "x" "(integer) position on the x axis"
instance ToCapture (Capture "y" Int) where
toCapture _ = DocCapture "y" "(integer) position on the y axis"
instance ToSample T3.Position where
toSamples _ = singleSample (T3.Position 3 14)
instance ToParam (QueryParam "name" String) where
toParam _ =
DocQueryParam "name"
["Alp", "John Doe", "..."]
"Name of the person to say hello to."
Normal
instance ToSample T3.HelloMessage where
toSamples _ =
[ ("When a value is provided for 'name'", T3.HelloMessage "Hello, Alp")
, ("When 'name' is not specified", T3.HelloMessage "Hello, anonymous coward")
]
ci :: T3.ClientInfo
ci = T3.ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]
instance ToSample T3.ClientInfo where
toSamples _ = singleSample ci
instance ToSample T3.Email where
toSamples _ = singleSample (T3.emailForClient ci)
api :: Proxy DocsAPI
api = Proxy
docsBS :: ByteString
docsBS = encodeUtf8
. pack
. markdown
$ docsWithIntros [intro] T3.api
where intro = DocIntro "Welcome" ["This is our super webservice's API.", "Enjoy!"]
server :: Server DocsAPI
server = T3.server :<|> serveDocs
where serveDocs _ respond =
respond $ responseLBS ok200 [plain] docsBS
plain = ("Content-Type", "text/plain")
app :: Application
app = serve api server

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

@ -1,52 +0,0 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T2 where
import Data.Aeson
import Data.Time.Calendar
import GHC.Generics
import Network.Wai
import Servant
data User = User
{ name :: String
, age :: Int
, email :: String
, registration_date :: Day
} deriving (Eq, Show, Generic)
#if !MIN_VERSION_aeson(0,10,0)
-- orphan ToJSON instance for Day. necessary to derive one for User
instance ToJSON Day where
-- display a day in YYYY-mm-dd format
toJSON d = toJSON (showGregorian d)
#endif
instance ToJSON User
type UserAPI = "users" :> Get '[JSON] [User]
:<|> "albert" :> Get '[JSON] User
:<|> "isaac" :> Get '[JSON] User
isaac :: User
isaac = User "Isaac Newton" 372 "isaac@newton.co.uk" (fromGregorian 1683 3 1)
albert :: User
albert = User "Albert Einstein" 136 "ae@mc2.org" (fromGregorian 1905 12 1)
users :: [User]
users = [isaac, albert]
userAPI :: Proxy UserAPI
userAPI = Proxy
server :: Server UserAPI
server = return users
:<|> return albert
:<|> return isaac
app :: Application
app = serve userAPI server

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

@ -1,84 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T3 where
import Control.Monad.Trans.Except
import Data.Aeson
import Data.List
import GHC.Generics
import Network.Wai
import Servant
data Position = Position
{ x :: Int
, y :: Int
} deriving (Show, Generic)
instance FromJSON Position
instance ToJSON Position
newtype HelloMessage = HelloMessage { msg :: String }
deriving (Show, Generic)
instance FromJSON HelloMessage
instance ToJSON HelloMessage
data ClientInfo = ClientInfo
{ name :: String
, email :: String
, age :: Int
, interested_in :: [String]
} deriving (Show, Generic)
instance FromJSON ClientInfo
instance ToJSON ClientInfo
data Email = Email
{ from :: String
, to :: String
, subject :: String
, body :: String
} deriving (Show, Generic)
instance FromJSON Email
instance ToJSON Email
emailForClient :: ClientInfo -> Email
emailForClient c = Email from' to' subject' body'
where from' = "great@company.com"
to' = email c
subject' = "Hey " ++ name c ++ ", we miss you!"
body' = "Hi " ++ name c ++ ",\n\n"
++ "Since you've recently turned " ++ show (age c)
++ ", have you checked out our latest "
++ intercalate ", " (interested_in c)
++ " products? Give us a visit!"
type API = "position" :> Capture "x" Int :> Capture "y" Int :> Get '[JSON] Position
:<|> "hello" :> QueryParam "name" String :> Get '[JSON] HelloMessage
:<|> "marketing" :> ReqBody '[JSON] ClientInfo :> Post '[JSON] Email
api :: Proxy API
api = Proxy
server :: Server API
server = position
:<|> hello
:<|> marketing
where position :: Int -> Int -> ExceptT ServantErr IO Position
position x y = return (Position x y)
hello :: Maybe String -> ExceptT ServantErr IO HelloMessage
hello mname = return . HelloMessage $ case mname of
Nothing -> "Hello, anonymous coward"
Just n -> "Hello, " ++ n
marketing :: ClientInfo -> ExceptT ServantErr IO Email
marketing clientinfo = return (emailForClient clientinfo)
app :: Application
app = serve api server

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

@ -1,63 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T4 where
import Data.Aeson
import Data.Foldable (foldMap)
import GHC.Generics
import Lucid
import Network.Wai
import Servant
import Servant.HTML.Lucid
data Person = Person
{ firstName :: String
, lastName :: String
, age :: Int
} deriving Generic -- for the JSON instance
-- JSON serialization
instance ToJSON Person
-- HTML serialization of a single person
instance ToHtml Person where
toHtml person =
tr_ $ do
td_ (toHtml $ firstName person)
td_ (toHtml $ lastName person)
td_ (toHtml . show $ age person)
toHtmlRaw = toHtml
-- HTML serialization of a list of persons
instance ToHtml [Person] where
toHtml persons = table_ $ do
tr_ $ do
th_ "first name"
th_ "last name"
th_ "age"
foldMap toHtml persons
toHtmlRaw = toHtml
persons :: [Person]
persons =
[ Person "Isaac" "Newton" 372
, Person "Albert" "Einstein" 136
]
type PersonAPI = "persons" :> Get '[JSON, HTML] [Person]
personAPI :: Proxy PersonAPI
personAPI = Proxy
server :: Server PersonAPI
server = return persons
app :: Application
app = serve personAPI server

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

@ -1,37 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T5 where
import Control.Monad.IO.Class
import Control.Monad.Trans.Except
import Data.Aeson
import GHC.Generics
import Network.Wai
import Servant
import System.Directory
type IOAPI = "myfile.txt" :> Get '[JSON] FileContent
ioAPI :: Proxy IOAPI
ioAPI = Proxy
newtype FileContent = FileContent
{ content :: String }
deriving Generic
instance ToJSON FileContent
server :: Server IOAPI
server = do
exists <- liftIO (doesFileExist "myfile.txt")
if exists
then liftIO (readFile "myfile.txt") >>= return . FileContent
else throwE custom404Err
where custom404Err = err404 { errBody = "myfile.txt just isn't there, please leave this server alone." }
app :: Application
app = serve ioAPI server

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

@ -1,18 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T6 where
import Network.Wai
import Servant
type API = "code" :> Raw
api :: Proxy API
api = Proxy
server :: Server API
server = serveDirectory "tutorial"
app :: Application
app = serve api server

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

@ -1,33 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T7 where
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Network.Wai
import Servant
type ReaderAPI = "a" :> Get '[JSON] Int
:<|> "b" :> Get '[JSON] String
readerAPI :: Proxy ReaderAPI
readerAPI = Proxy
readerServerT :: ServerT ReaderAPI (Reader String)
readerServerT = a :<|> b
where a :: Reader String Int
a = return 1797
b :: Reader String String
b = ask
readerServer :: Server ReaderAPI
readerServer = enter readerToEither readerServerT
where readerToEither :: Reader String :~> ExceptT ServantErr IO
readerToEither = Nat $ \r -> return (runReader r "hi")
app :: Application
app = serve readerAPI readerServer

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

@ -1,49 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T8 where
import Control.Monad.Trans.Except
import Network.HTTP.Client (Manager, defaultManagerSettings,
newManager)
import Servant
import Servant.Client
import System.IO.Unsafe (unsafePerformIO)
import T3
position :: Int -- ^ value for "x"
-> Int -- ^ value for "y"
-> ExceptT ServantError IO Position
hello :: Maybe String -- ^ an optional value for "name"
-> ExceptT ServantError IO HelloMessage
marketing :: ClientInfo -- ^ value for the request body
-> ExceptT ServantError IO Email
position :<|> hello :<|> marketing = client api baseUrl manager
baseUrl :: BaseUrl
baseUrl = BaseUrl Http "localhost" 8081 ""
{-# NOINLINE manager #-}
manager :: Manager
manager = unsafePerformIO $ newManager defaultManagerSettings
queries :: ExceptT ServantError IO (Position, HelloMessage, Email)
queries = do
pos <- position 10 10
msg <- hello (Just "servant")
em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
return (pos, msg, em)
run :: IO ()
run = do
res <- runExceptT queries
case res of
Left err -> putStrLn $ "Error: " ++ show err
Right (pos, msg, em) -> do
print pos
print msg
print em

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

@ -1,105 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T9 where
import Control.Applicative
import Control.Monad.IO.Class
import Data.Aeson
import Data.Text (Text)
import GHC.Generics
import Network.Wai
import Servant
import Servant.JS
import System.Random
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Language.Javascript.JQuery as JQ
data Point = Point
{ x :: Double
, y :: Double
} deriving Generic
instance ToJSON Point
randomPoint :: MonadIO m => m Point
randomPoint = liftIO . getStdRandom $ \g ->
let (rx, g') = randomR (-1, 1) g
(ry, g'') = randomR (-1, 1) g'
in (Point rx ry, g'')
data Search a = Search
{ query :: Text
, results :: [a]
} deriving Generic
mkSearch :: Text -> [a] -> Search a
mkSearch = Search
instance ToJSON a => ToJSON (Search a)
data Book = Book
{ author :: Text
, title :: Text
, year :: Int
} deriving Generic
instance ToJSON Book
book :: Text -> Text -> Int -> Book
book = Book
books :: [Book]
books =
[ book "Paul Hudak" "The Haskell School of Expression: Learning Functional Programming through Multimedia" 2000
, book "Bryan O'Sullivan, Don Stewart, and John Goerzen" "Real World Haskell" 2008
, book "Miran Lipovača" "Learn You a Haskell for Great Good!" 2011
, book "Graham Hutton" "Programming in Haskell" 2007
, book "Simon Marlow" "Parallel and Concurrent Programming in Haskell" 2013
, book "Richard Bird" "Introduction to Functional Programming using Haskell" 1998
]
searchBook :: Monad m => Maybe Text -> m (Search Book)
searchBook Nothing = return (mkSearch "" books)
searchBook (Just q) = return (mkSearch q books')
where books' = filter (\b -> q' `T.isInfixOf` T.toLower (author b)
|| q' `T.isInfixOf` T.toLower (title b)
)
books
q' = T.toLower q
type API = "point" :> Get '[JSON] Point
:<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book)
type API' = API :<|> Raw
api :: Proxy API
api = Proxy
api' :: Proxy API'
api' = Proxy
server :: Server API
server = randomPoint
:<|> searchBook
server' :: Server API'
server' = server
:<|> serveDirectory "tutorial/t9"
apiJS :: Text
apiJS = jsForAPI api jquery
writeJSFiles :: IO ()
writeJSFiles = do
TIO.writeFile "tutorial/t9/api.js" apiJS
jq <- TIO.readFile =<< JQ.file
TIO.writeFile "tutorial/t9/jq.js" jq
app :: Application
app = serve api' server'

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

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

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

@ -1,39 +0,0 @@
import Network.Wai
import Network.Wai.Handler.Warp
import System.Environment
import qualified T1
import qualified T10
import qualified T2
import qualified T3
import qualified T4
import qualified T5
import qualified T6
import qualified T7
import qualified T9
app :: String -> (Application -> IO ()) -> IO ()
app n f = case n of
"1" -> f T1.app
"2" -> f T2.app
"3" -> f T3.app
"4" -> f T4.app
"5" -> f T5.app
"6" -> f T6.app
"7" -> f T7.app
"8" -> f T3.app
"9" -> T9.writeJSFiles >> f T9.app
"10" -> f T10.app
_ -> usage
main :: IO ()
main = do
args <- getArgs
case args of
[n] -> app n (run 8081)
_ -> usage
usage :: IO ()
usage = do
putStrLn "Usage:\t tutorial N"
putStrLn "\t\twhere N is the number of the example you want to run."

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

@ -1,51 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
import Data.Aeson
import Data.Text
import GHC.Generics
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Middleware.RequestLogger
import Servant
data Product = Product
{ name :: Text
, brand :: Text
, current_price_eur :: Double
, available :: Bool
} deriving (Eq, Show, Generic)
instance ToJSON Product
products :: [Product]
products = [p1, p2]
where p1 = Product "Haskell laptop sticker"
"GHC Industries"
2.50
True
p2 = Product "Foldable USB drive"
"Well-Typed"
13.99
False
type SimpleAPI = Get '[JSON] [Product]
simpleAPI :: Proxy SimpleAPI
simpleAPI = Proxy
server :: Server SimpleAPI
server = return products
-- logStdout :: Middleware
-- i.e, logStdout :: Application -> Application
-- serve :: Proxy api -> 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

2
sources.txt
View file

@ -5,7 +5,7 @@ servant-docs
servant-foreign servant-foreign
servant-js servant-js
servant-server servant-server
servant-examples
servant-blaze servant-blaze
servant-lucid servant-lucid
servant-mock servant-mock
doc/tutorial

7
stack.yaml
View file

@ -7,15 +7,18 @@ packages:
- servant-cassava/ - servant-cassava/
- servant-client/ - servant-client/
- servant-docs/ - servant-docs/
- servant-examples/
- servant-foreign/ - servant-foreign/
- servant-js/ - servant-js/
- servant-lucid/ - servant-lucid/
- servant-mock/ - servant-mock/
- servant-server/ - servant-server/
- doc/tutorial
extra-deps: extra-deps:
- base-compat-0.9.0 - base-compat-0.9.0
- engine-io-wai-1.0.2 - engine-io-wai-1.0.2
- control-monad-omega-0.3.1 - control-monad-omega-0.3.1
- should-not-typecheck-2.0.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