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

Merge pull request #867 from haskell-servant/cookbook

Browse source 
[Docs] Cookbook
This commit is contained in:
Oleg Grenrus 2017-12-27 14:11:52 +02:00 committed by GitHub
commit 68bc41b41d
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
21 changed files with 1366 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -25,8 +25,6 @@ cabal.config
*.hp
Setup
.stack-work
shell.nix
default.nix
doc/_build
doc/venv
doc/tutorial/static/api.js

7
cabal.project
View file

@ -5,6 +5,13 @@ packages: servant/
servant-foreign/
servant-server/
doc/tutorial/
doc/cookbook/basic-auth/
doc/cookbook/db-postgres-pool/
doc/cookbook/db-sqlite-simple/
doc/cookbook/jwt-and-basic-auth/
doc/cookbook/file-upload/
doc/cookbook/structuring-apis/
doc/cookbook/https/
allow-newer: servant-js:servant-foreign

179
doc/cookbook/basic-auth/BasicAuth.lhs Normal file
View file

@ -0,0 +1,179 @@
# Basic Authentication
Let's see a simple example of a web application with a
single endpoint, protected by
[Basic Authentication](https://en.wikipedia.org/wiki/Basic_access_authentication).
First, some throat clearing.
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import Control.Concurrent
import Control.Exception
import qualified Data.Map as Map
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant
import Servant.Client
```
We will be dealing with a very simple model of users, as shown below.
Our "user database" will just be a map from usernames to full user details.
For the sake of simplicity, it will just be read only but the same code could
be used with mutable references, database connections, files and more in place
of our `Map`.
``` haskell
type Username = T.Text
type Password = T.Text
type Website = T.Text
data User = User
{ user :: Username
, pass :: Password
, site :: Website
} deriving (Eq, Show)
-- could be a postgres connection, a file, anything.
type UserDB = Map.Map Username User
-- create a "database" from a list of users
createUserDB :: [User] -> UserDB
createUserDB users = Map.fromList [ (user u, u) | u <- users ]
-- our test database
userDB :: UserDB
userDB = createUserDB
[ User "john" "shhhh" "john.com"
, User "foo" "bar" "foobar.net"
]
```
Our API will contain a single endpoint, returning the authenticated
user's own website.
``` haskell
-- a 'GET /mysite' endpoint, protected by basic authentication
type API = BasicAuth "People's websites" User :> "mysite" :> Get '[JSON] Website
{- if there were more endpoints to be protected, one could write:
type API = BasicAuth "People's websites" User :>
( "foo" :> Get '[JSON] Foo
:<|> "bar" :> Get '[JSON] Bar
)
-}
api :: Proxy API
api = Proxy
server :: Server API
server usr = return (site usr)
```
In order to protect our endpoint (`"mysite" :> Get '[JSON] Website`), we simply
drop the `BasicAuth` combinator in front of it. Its first parameter,
`"People's websites"` in our example, is the realm, which is an arbitrary string
identifying the protected resources. The second parameter, `User` in our example,
corresponds to the type we want to use to represent authenticated users. It could
be anything.
When using `BasicAuth` in an API, the server implementation "gets" an argument
of the authenticated user type used with `BasicAuth`, `User` in our case, in the
"corresponding spot". In this example, the server implementation simply returns
the `site` field of the authenticated user. More realistic applications would
have endpoints that take other arguments and where a lot more logic would
be implemented. But in a sense, `BasicAuth` adds an argument just like `Capture`,
`QueryParam`, `ReqBody` and friends. But instead of performing some form of
decoding logic behind the scenes, servant runs some "basic auth check" that the
user provides.
In our case, we need access to our user database, so we simply
take it as an argument. A more serious implementation would probably take
a database connection or even a connection pool.
``` haskell
-- provided we are given a user database, we can supply
-- a function that checks the basic auth credentials
-- against our database.
checkBasicAuth :: UserDB -> BasicAuthCheck User
checkBasicAuth db = BasicAuthCheck $ \basicAuthData ->
let username = decodeUtf8 (basicAuthUsername basicAuthData)
password = decodeUtf8 (basicAuthPassword basicAuthData)
in
case Map.lookup username db of
Nothing -> return NoSuchUser
Just u -> if pass u == password
then return (Authorized u)
else return BadPassword
```
This check simply looks up the user in the "database" and makes sure the
right password was used. For reference, here are the definitions of
`BasicAuthResult` and `BasicAuthCheck`:
```
-- | The result of authentication/authorization
data BasicAuthResult usr
= Unauthorized
| BadPassword
| NoSuchUser
| Authorized usr
deriving (Eq, Show, Read, Generic, Typeable, Functor)
-- | Datatype wrapping a function used to check authentication.
newtype BasicAuthCheck usr = BasicAuthCheck
{ unBasicAuthCheck :: BasicAuthData
-> IO (BasicAuthResult usr)
}
deriving (Generic, Typeable, Functor)
```
This is all great, but how is our `BasicAuth` combinator supposed to know
that it should use our `checkBasicAuth` from above? The answer is that it
simply expects to find a `BasicAuthCheck` value for the right user type in
the `Context` with which we serve the application, where `Context` is just
servant's way to allow users to communicate some configuration of sorts to
combinators. It is nothing more than an heterogeneous list and we can create
a context with our auth check and run our application with it with the following
code:
``` haskell
runApp :: UserDB -> IO ()
runApp db = run 8080 (serveWithContext api ctx server)
where ctx = checkBasicAuth db :. EmptyContext
```
`ctx` above is just a context with one element, `checkBasicAuth db`,
whose type is `BasicAuthCheck User`. In order to say that we want to serve our
application using the supplied context, we just have to use `serveWithContext`
in place of `serve`.
Finally, let's derive a client to this endpoint as well in order to see our
server in action!
``` haskell
getSite :: BasicAuthData -> ClientM Website
getSite = client api
main :: IO ()
main = do
mgr <- newManager defaultManagerSettings
bracket (forkIO $ runApp userDB) killThread $ \_ ->
runClientM (getSite u) (ClientEnv mgr (BaseUrl Http "localhost" 8080 ""))
>>= print
where u = BasicAuthData "foo" "bar"
```
This program prints `Right "foobar.net"`, as expected. Feel free to change this
code and see what happens when you specify credentials that are not in the
database.
The entire program covered here is available as a literate Haskell file
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/basic-auth),
along with a `cabal` project.

30
doc/cookbook/basic-auth/basic-auth.cabal Normal file
View file

@ -0,0 +1,30 @@
name: cookbook-basic-auth
version: 0.1
synopsis: Basic Authentication cookbook example
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
cabal-version: >=1.10
executable cookbook-basic-auth
if impl(ghc < 7.10.1)
buildable: False
main-is: BasicAuth.lhs
build-depends: base == 4.*
, text >= 1.2
, aeson >= 1.2
, containers >= 0.5
, servant
, servant-client
, servant-server
, warp >= 3.2
, wai >= 3.2
, http-types >= 0.10
, markdown-unlit >= 0.4
, http-client >= 0.5
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

10
doc/cookbook/cabal.project Normal file
View file

@ -0,0 +1,10 @@
packages:
basic-auth/
db-sqlite-simple/
db-postgres-pool/
../../servant
../../servant-server
../../servant-client-core
../../servant-client
../../servant-docs
../../servant-foreign

143
doc/cookbook/db-postgres-pool/PostgresPool.lhs Normal file
View file

@ -0,0 +1,143 @@
# PostgreSQL connection pool
Let's see how we can write a simple web application that uses a
[PostgreSQL](https://www.postgresql.org/) database to store simple textual
messages, just like in the SQLite cookbook recipe. The main difference,
besides the database technology, is that in this example we will be using
a pool of connections to talk to the database server. The pool abstraction
will be provided by the
[resource-pool](https://hackage.haskell.org/package/resource-pool) library.
As usual, we start with a little bit of throat clearing.
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import Data.ByteString (ByteString)
import Control.Concurrent
import Control.Exception (bracket)
import Control.Monad.IO.Class
import Data.Pool
import Database.PostgreSQL.Simple
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant
import Servant.Client
type DBConnectionString = ByteString
```
We will only care about a single type here, the messages. We want to
be able to add a new one and retrieve them all, using two different
endpoints.
``` haskell
type Message = String
type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent
:<|> Get '[JSON] [Message]
api :: Proxy API
api = Proxy
```
We proceed with a simple function for creating a table
for holding our messages if it doesn't already exist, given
a PostgreSQL connection string.
``` haskell
initDB :: DBConnectionString -> IO ()
initDB connstr = bracket (connectPostgreSQL connstr) close $ \conn -> do
execute_ conn
"CREATE TABLE IF NOT EXISTS messages (msg text not null)"
return ()
```
Next, our server implementation. It will be parametrised (take as
argument) by the pool of database connections that handlers can use to
talk to the PostgreSQL database. The resource pool abstraction allows us
to flexibly set up a whole bunch of PostgreSQL connections tailored to our
needs and then to forget about it all by simply asking for a connection
using `withResource`.
The handlers are straighforward. One takes care of inserting a new
value in the database while the other fetches all messages and returns
them. We also provide a function for serving our web app given a PostgreSQL
connection pool, which simply calls servant-server's `serve` function.
``` haskell
server :: Pool Connection -> Server API
server conns = postMessage :<|> getMessages
where postMessage :: Message -> Handler NoContent
postMessage msg = do
liftIO . withResource conns $ \conn ->
execute conn
"INSERT INTO messages VALUES (?)"
(Only msg)
return NoContent
getMessages :: Handler [Message]
getMessages = fmap (map fromOnly) . liftIO $
withResource conns $ \conn ->
query_ conn "SELECT msg FROM messages"
runApp :: Pool Connection -> IO ()
runApp conns = run 8080 (serve api $ server conns)
```
We will also need a function for initialising our connection pool.
`resource-pool` is quite configurable, feel free to wander in
[its documentation](https://hackage.haskell.org/package/resource-pool)
to gain a better understanding of how it works and what the configuration
knobs are. I will be using some dummy values in this example.
``` haskell
initConnectionPool :: DBConnectionString -> IO (Pool Connection)
initConnectionPool connStr =
createPool (connectPostgreSQL connStr)
close
2 -- stripes
60 -- unused connections are kept open for a minute
10 -- max. 10 connections open per stripe
```
Let's finally derive some clients for our API and use them to
insert two messages and retrieve them in `main`, after setting up
our pool of database connections.
``` haskell
postMsg :: Message -> ClientM NoContent
getMsgs :: ClientM [Message]
postMsg :<|> getMsgs = client api
main :: IO ()
main = do
-- you could read this from some configuration file,
-- environment variable or somewhere else instead.
-- you will need to either change this connection string OR
-- set some environment variables (see
-- https://www.postgresql.org/docs/9.5/static/libpq-envars.html)
-- to point to a running PostgreSQL server for this example to work.
let connStr = ""
pool <- initConnectionPool connStr
initDB connStr
mgr <- newManager defaultManagerSettings
bracket (forkIO $ runApp pool) killThread $ \_ -> do
ms <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
postMsg "hello"
postMsg "world"
getMsgs
print ms
```
This program prints `Right ["hello","world"]` the first time it is executed,
`Right ["hello","world","hello","world"]` the second time and so on.
You could alternatively have the handlers live in `ReaderT (Pool Connection)`
and access the pool using e.g `ask`, but this would be more complicated
than simply taking the pool as argument.
The entire source for this example is available as a cabal project
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/db-postgres-pool).

32
doc/cookbook/db-postgres-pool/db-postgres-pool.cabal Normal file
View file

@ -0,0 +1,32 @@
name: cookbook-db-postgres-pool
version: 0.1
synopsis: Simple PostgreSQL connection pool cookbook example
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
cabal-version: >=1.10
executable cookbook-db-postgres-pool
if impl(ghc < 7.10.1)
buildable: False
main-is: PostgresPool.lhs
build-depends: base == 4.*
, bytestring >= 0.10
, text >= 1.2
, aeson >= 1.2
, servant
, servant-client
, servant-server
, warp >= 3.2
, wai >= 3.2
, http-types >= 0.10
, markdown-unlit >= 0.4
, http-client >= 0.5
, postgresql-simple >= 0.5
, resource-pool >= 0.2
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

100
doc/cookbook/db-sqlite-simple/DBConnection.lhs Normal file
View file

@ -0,0 +1,100 @@
# SQLite database
Let's see how we can write a simple web application that uses an
[SQLite](https://www.sqlite.org/) database to store simple textual
messages. As usual, we start with a little bit of throat clearing.
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
import Control.Concurrent
import Control.Exception (bracket)
import Control.Monad.IO.Class
import Database.SQLite.Simple
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant
import Servant.Client
```
We will only care about a single type here, the messages. We want to
be able to add a new one and retrieve them all, using two different
endpoints.
``` haskell
type Message = String
type API = ReqBody '[PlainText] Message :> Post '[JSON] NoContent
:<|> Get '[JSON] [Message]
api :: Proxy API
api = Proxy
```
We proceed with a simple function for creating a table
for holding our messages if it doesn't already exist.
``` haskell
initDB :: FilePath -> IO ()
initDB dbfile = withConnection dbfile $ \conn ->
execute_ conn
"CREATE TABLE IF NOT EXISTS messages (msg text not null)"
```
Next, our server implementation. It will be parametrised (take as
argument) by the name of the file that contains our SQLite database.
The handlers are straighforward. One takes care of inserting a new
value in the database while the other fetches all messages and returns
them. We also provide a function for serving our web app given an
SQLite database file, which simply calls servant-server's `serve` function.
``` haskell
server :: FilePath -> Server API
server dbfile = postMessage :<|> getMessages
where postMessage :: Message -> Handler NoContent
postMessage msg = do
liftIO . withConnection dbfile $ \conn ->
execute conn
"INSERT INTO messages VALUES (?)"
(Only msg)
return NoContent
getMessages :: Handler [Message]
getMessages = fmap (map fromOnly) . liftIO $
withConnection dbfile $ \conn ->
query_ conn "SELECT msg FROM messages"
runApp :: FilePath -> IO ()
runApp dbfile = run 8080 (serve api $ server dbfile)
```
Let's also derive some clients for our API and use them to
insert two messages and retrieve them in `main`.
``` haskell
postMsg :: Message -> ClientM NoContent
getMsgs :: ClientM [Message]
postMsg :<|> getMsgs = client api
main :: IO ()
main = do
-- you could read this from some configuration file,
-- environment variable or somewhere else instead.
let dbfile = "test.db"
initDB dbfile
mgr <- newManager defaultManagerSettings
bracket (forkIO $ runApp dbfile) killThread $ \_ -> do
ms <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" 8080 "")) $ do
postMsg "hello"
postMsg "world"
getMsgs
print ms
```
This program prints `Right ["hello","world"]` the first time it is executed,
`Right ["hello","world","hello","world"]` the second time and so on.
The entire source for this example is available as a cabal project
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/db-sqlite-simple).

30
doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal Normal file
View file

@ -0,0 +1,30 @@
name: cookbook-db-sqlite-simple
version: 0.1
synopsis: Simple SQLite DB cookbook example
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
cabal-version: >=1.10
executable cookbook-db-sqlite-simple
if impl(ghc < 7.10.1)
buildable: False
main-is: DBConnection.lhs
build-depends: base == 4.*
, text >= 1.2
, aeson >= 1.2
, servant
, servant-client
, servant-server
, warp >= 3.2
, wai >= 3.2
, http-types >= 0.10
, markdown-unlit >= 0.4
, http-client >= 0.5
, sqlite-simple >= 0.4
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

140
doc/cookbook/file-upload/FileUpload.lhs Normal file
View file

@ -0,0 +1,140 @@
# File Upload (`multipart/form-data`)
In this recipe, we will implement a web application
with a single endpoint that can process
`multipart/form-data` request bodies, which most
commonly come from HTML forms that allow file upload.
As usual, a bit of throat clearing.
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Data.Text.Encoding (encodeUtf8)
import Network (withSocketsDo)
import Network.HTTP.Client hiding (Proxy)
import Network.HTTP.Client.MultipartFormData
import Network.Wai.Handler.Warp
import Servant
import Servant.Multipart
import qualified Data.ByteString.Lazy as LBS
```
Our API consists in a single `POST` endpoint at `/`
that takes a `multipart/form-data` request body and
pretty-prints the data it got to stdout before returning `0`
(because why not).
``` haskell
type API = MultipartForm Mem (MultipartData Mem) :> Post '[JSON] Integer
api :: Proxy API
api = Proxy
```
Because of some technicalities, multipart form data is not
represented as a good old content type like `JSON` in servant,
that one could use with `ReqBody`, but instead is its own
dedicated `ReqBody`-like combinator named
[`MultiPartForm`](https://hackage.haskell.org/package/servant-multipart-0.11/docs/Servant-Multipart.html#t:MultipartForm).
This combinator takes two parameters. The first one is the
"backend" to use. Currently, you only have the choice between
`Mem` and `Tmp`. The former loads the entire input in memory,
even the uploadedd files, while `Tmp` will stream uploaded
files to some temporary directory.
The second parameter is the type you want the multipart data
to be decoded to. Indeed there is a `FromMultipart` class that
allows you to specify how to decode multipart form data from
`MultipartData` to a custom type of yours. Here we use the
trivial "decoding" to `MultipartData` itself, and simply
will get our hands on the raw input. If you want to use
a type of yours, see the documentation for
[`FromMultipart`](https://hackage.haskell.org/package/servant-multipart-0.11/docs/Servant-Multipart.html#t:FromMultipart).
Our only request handler has type `MultipartData Mem -> Handler Integer`.
All it does is list the textual and file inputs that
were sent in the multipart request body. The textual
inputs are in the `inputs` field while the file inputs
are in the `files` field of `multipartData`.
``` haskell
-- MultipartData consists in textual inputs,
-- accessible through its "inputs" field, as well
-- as files, accessible through its "files" field.
upload :: Server API
upload multipartData = do
liftIO $ do
putStrLn "Inputs:"
forM_ (inputs multipartData) $ \input ->
putStrLn $ " " ++ show (iName input)
++ " -> " ++ show (iValue input)
forM_ (files multipartData) $ \file -> do
let content = fdPayload file
putStrLn $ "Content of " ++ show (fdFileName file)
LBS.putStr content
return 0
startServer :: IO ()
startServer = run 8080 (serve api upload)
```
Finally, a main function that brings up our server and
sends some test request with `http-client` (and not
servant-client this time, has servant-multipart does not
yet have support for client generation.
``` haskell
main :: IO ()
main = withSocketsDo . bracket (forkIO startServer) killThread $ \_threadid -> do
-- we fork the server in a separate thread and send a test
-- request to it from the main thread.
manager <- newManager defaultManagerSettings
req <- parseRequest "http://localhost:8080/"
resp <- flip httpLbs manager =<< formDataBody form req
print resp
where form =
[ partBS "title" "World"
, partBS "text" $ encodeUtf8 "Hello"
, partFileSource "file" "./README.md"
]
```
If you run this, you should get:
``` bash
$ cabal new-build cookbook-file-upload
[...]
$ dist-newstyle/build/x86_64-linux/ghc-8.2.1/cookbook-file-upload-0.1/x/cookbook-file-upload/build/cookbook-file-upload/cookbook-file-upload
Inputs:
"title" -> "World"
"text" -> "Hello"
Content of "README.md"
# servant - A Type-Level Web DSL
![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)
## Getting Started
We have a [tutorial](http://haskell-servant.readthedocs.org/en/stable/tutorial/index.html) that
introduces the core features of servant. After this article, you should be able
to write your first servant webservices, learning the rest from the haddocks'
examples.
[...]
Response {responseStatus = Status {statusCode = 200, statusMessage = "OK"}, responseVersion = HTTP/1.1, responseHeaders = [("Transfer-Encoding","chunked"),("Date","Fri, 08 Dec 2017 16:50:14 GMT"),("Server","Warp/3.2.13"),("Content-Type","application/json;charset=utf-8")], responseBody = "0", responseCookieJar = CJ {expose = []}, responseClose' = ResponseClose}
```
As usual, the code for this recipe is available in a cabal project
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/file-upload).

30
doc/cookbook/file-upload/file-upload.cabal Normal file
View file

@ -0,0 +1,30 @@
name: cookbook-file-upload
version: 0.1
synopsis: File upload cookbook example
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
cabal-version: >=1.10
executable cookbook-file-upload
if impl(ghc < 7.10.1)
buildable: False
main-is: FileUpload.lhs
build-depends: base == 4.*
, text >= 1.2
, mtl >= 2.2
, network >= 2.6
, bytestring >= 0.10
, servant
, servant-server
, servant-multipart
, warp >= 3.2
, wai >= 3.2
, markdown-unlit >= 0.4
, http-client >= 0.5
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

62
doc/cookbook/https/Https.lhs Normal file
View file

@ -0,0 +1,62 @@
# Serving web applications over HTTPS
This short recipe shows how one can serve a servant application
over HTTPS, by simply using `warp-tls` instead of `warp` to provide
us a `run` function for running the `Application` that we get by
calling `serve`.
As usual, we start by clearing our throat of a few language extensions
and imports.
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS
import Servant
```
No need to work with a complicated API here, let's
make it as simple as it gets:
``` haskell
type API = Get '[JSON] Int
api :: Proxy API
api = Proxy
server :: Server API
server = return 10
app :: Application
app = serve api server
```
It's now time to actually run the `Application`.
The [`warp-tls`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html)
package provides two functions for running an `Application`, called
[`runTLS`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLS)
and [`runTLSSocket`](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#v:runTLSSocket).
We will be using the first one.
It takes two arguments,
[the TLS settings](https://hackage.haskell.org/package/warp-tls-3.2.4/docs/Network-Wai-Handler-WarpTLS.html#t:TLSSettings)
(certificates, keys, ciphers, etc)
and [the warp settings](https://hackage.haskell.org/package/warp-3.2.12/docs/Network-Wai-Handler-Warp-Internal.html#t:Settings)
(port, logger, etc).
We will be using very simple settings for this example but you are of
course invited to read the documentation for those types to find out
about all the knobs that you can play with.
``` haskell
main :: IO ()
main = runTLS tlsOpts warpOpts app
where tlsOpts = tlsSettings "cert.pem" "secret-key.pem"
warpOpts = setPort 8080 defaultSettings
```
This program is available as a cabal project
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/https).

25
doc/cookbook/https/https.cabal Normal file
View file

@ -0,0 +1,25 @@
name: cookbook-https
version: 0.1
synopsis: HTTPS cookbook example
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
cabal-version: >=1.10
executable cookbook-https
if impl(ghc < 7.10.1)
buildable: False
main-is: Https.lhs
build-depends: base == 4.*
, servant
, servant-server
, wai >= 3.2
, warp >= 3.2
, warp-tls >= 3.2
, markdown-unlit >= 0.4
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

26
doc/cookbook/index.rst Normal file
View file

@ -0,0 +1,26 @@
Cookbook
========
This page is a *collective effort* whose goal is to show
how to solve many common problems with servant. If you're
interested in contributing examples of your own, feel free
to open an issue or a pull request on
`our github repository <https://github.com/haskell-servant/servant>`_
or even to just get in touch with us on the **#servant** IRC channel
on freenode or on
`the mailing list <https://groups.google.com/forum/#!forum/haskell-servant>`_.
The scope is very wide. Simple and fancy authentication schemes,
file upload, type-safe links, working with CSV, .zip archives,
you name it!
.. toctree::
:maxdepth: 1
structuring-apis/StructuringApis.lhs
https/Https.lhs
db-sqlite-simple/DBConnection.lhs
db-postgres-pool/PostgresPool.lhs
basic-auth/BasicAuth.lhs
jwt-and-basic-auth/JWTAndBasicAuth.lhs
file-upload/FileUpload.lhs

252
doc/cookbook/jwt-and-basic-auth/JWTAndBasicAuth.lhs Normal file
View file

@ -0,0 +1,252 @@
# Combining JWT-based authentication with basic access authentication
In this example we will make a service with
[basic HTTP authentication](https://en.wikipedia.org/wiki/Basic_access_authentication)
for Haskell clients and other programs, as well as
with [JWT](https://en.wikipedia.org/wiki/JSON_Web_Token)-based
authentication for web browsers. Web browsers will still use basic
HTTP authentication to retrieve JWTs though.
**Warning**: this is insecure when done over plain HTTP,
so [TLS](https://en.wikipedia.org/wiki/Transport_Layer_Security)
should be used.
See [warp-tls](https://hackage.haskell.org/package/warp-tls) for that.
While basic authentication comes with Servant itself,
[servant-auth](https://hackage.haskell.org/package/servant-auth) and
[servant-auth-server](https://hackage.haskell.org/package/servant-auth-server)
packages are needed for the JWT-based one.
This recipe uses the following ingredients:
```haskell
{-# LANGUAGE OverloadedStrings, TypeFamilies, DataKinds,
DeriveGeneric, TypeOperators #-}
import Data.Aeson
import GHC.Generics
import Data.Proxy
import System.IO
import Network.HTTP.Client (newManager, defaultManagerSettings)
import Network.Wai.Handler.Warp
import Servant as S
import Servant.Client
import Servant.Auth as SA
import Servant.Auth.Server as SAS
import Control.Monad.IO.Class (liftIO)
import Data.Map as M
import Data.ByteString (ByteString)
port :: Int
port = 3001
```
## Authentication
Below is how we'll represent a user: usually user identifier is handy
to keep around, along with their role if
[role-based access control](https://en.wikipedia.org/wiki/Role-based_access_control)
is used, and other commonly needed information, such as an
organization identifier:
```haskell
data AuthenticatedUser = AUser { auID :: Int
, auOrgID :: Int
} deriving (Show, Generic)
```
The following instances are needed for JWT:
```haskell
instance ToJSON AuthenticatedUser
instance FromJSON AuthenticatedUser
instance ToJWT AuthenticatedUser
instance FromJWT AuthenticatedUser
```
We'll have to use a bit of imagination to pretend that the following
`Map` is a database connection pool:
```haskell
type Login = ByteString
type Password = ByteString
type DB = Map (Login, Password) AuthenticatedUser
type Connection = DB
type Pool a = a
initConnPool :: IO (Pool Connection)
initConnPool = pure $ fromList [ (("user", "pass"), AUser 1 1)
, (("user2", "pass2"), AUser 2 1) ]
```
See the "PostgreSQL connection pool" recipe for actual connection
pooling, and we proceed to an authentication function that would use
our improvised DB connection pool and credentials provided by a user:
```haskell
authCheck :: Pool Connection
-> BasicAuthData
-> IO (AuthResult AuthenticatedUser)
authCheck connPool (BasicAuthData login password) = pure $
maybe SAS.Indefinite Authenticated $ M.lookup (login, password) connPool
```
**Warning**: make sure to use a proper password hashing function in
functions like this: see [bcrypt](https://en.wikipedia.org/wiki/Bcrypt),
[scrypt](https://en.wikipedia.org/wiki/Scrypt),
[pgcrypto](https://www.postgresql.org/docs/current/static/pgcrypto.html).
Unlike `Servant.BasicAuth`, `Servant.Auth` uses `FromBasicAuthData`
type class for the authentication process itself. But since our
connection pool will be initialized elsewhere, we'll have to pass it
somehow: it can be done via a context entry and `BasicAuthCfg` type
family. We can actually pass a function at once, to make it a bit more
generic:
```haskell
type instance BasicAuthCfg = BasicAuthData -> IO (AuthResult AuthenticatedUser)
instance FromBasicAuthData AuthenticatedUser where
fromBasicAuthData authData authCheckFunction = authCheckFunction authData
```
## API
Test API with a couple of endpoints:
```haskell
type TestAPI = "foo" :> Capture "i" Int :> Get '[JSON] ()
:<|> "bar" :> Get '[JSON] ()
```
We'll use this for server-side functions, listing the allowed
authentication methods using the `Auth` combinator:
```haskell
type TestAPIServer =
Auth '[SA.JWT, SA.BasicAuth] AuthenticatedUser :> TestAPI
```
But `Servant.Auth.Client` only supports JWT-based authentication, so
we'll have to use regular `Servant.BasicAuth` to derive client
functions that use basic access authentication:
```haskell
type TestAPIClient = S.BasicAuth "test" AuthenticatedUser :> TestAPI
```
## Client
Client code in this setting is the same as it would be with just
`Servant.BasicAuth`, using
[servant-client](https://hackage.haskell.org/package/servant-client):
```haskell
testClient :: IO ()
testClient = do
mgr <- newManager defaultManagerSettings
let (foo :<|> _) = client (Proxy :: Proxy TestAPIClient)
(BasicAuthData "name" "pass")
res <- runClientM (foo 42)
(ClientEnv mgr (BaseUrl Http "localhost" port ""))
hPutStrLn stderr $ case res of
Left err -> "Error: " ++ show err
Right r -> "Success: " ++ show r
```
## Server
Server code is slightly different -- we're getting `AuthResult` here:
```haskell
server :: Server TestAPIServer
server (Authenticated user) = handleFoo :<|> handleBar
where
handleFoo :: Int -> Handler ()
handleFoo n = liftIO $ hPutStrLn stderr $
concat ["foo: ", show user, " / ", show n]
handleBar :: Handler ()
handleBar = liftIO testClient
```
Catch-all for `BadPassword`, `NoSuchUser`, and `Indefinite`:
```haskell
server _ = throwAll err401
```
With `Servant.Auth`, we'll have to put both `CookieSettings` and
`JWTSettings` into context even if we're not using those, and we'll
put a partially applied `authCheck` function there as well, so that
`FromBasicAuthData` will be able to use it, while it will use our
connection pool. Otherwise it is similar to the usual way:
```haskell
mkApp :: Pool Connection -> IO Application
mkApp connPool = do
myKey <- generateKey
let jwtCfg = defaultJWTSettings myKey
authCfg = authCheck connPool
cfg = jwtCfg :. defaultCookieSettings :. authCfg :. EmptyContext
api = Proxy :: Proxy TestAPIServer
pure $ serveWithContext api cfg server
```
Finally, the main function:
```haskell
main :: IO ()
main = do
connPool <- initConnPool
let settings =
setPort port $
setBeforeMainLoop (hPutStrLn stderr
("listening on port " ++ show port)) $
defaultSettings
runSettings settings =<< mkApp connPool
```
## Usage
Now we can try it out with `curl`. First of all, let's ensure that it
fails with `err401` if we're not authenticated:
```
$ curl -v 'http://localhost:3001/bar'
…
< HTTP/1.1 401 Unauthorized
```
```
$ curl -v 'http://user:wrong_password@localhost:3001/bar'
…
< HTTP/1.1 401 Unauthorized
```
Now let's see that basic HTTP authentication works, and that we get
JWTs:
```
$ curl -v 'http://user:pass@localhost:3001/bar'
…
< HTTP/1.1 200 OK
…
< Set-Cookie: XSRF-TOKEN=lQE/sb1fW4rZ/FYUQZskI6RVRllG0CWZrQ0d3fXU4X0=; Path=/; Secure
< Set-Cookie: JWT-Cookie=eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsiYXVPcmdJRCI6MSwiYXVJRCI6MX19.6ZQba-Co5Ul4wpmU34zXlI75wmasxDfaGRmO3BsOx-ONupX93OBfyYBCIJ3tbWMXKBVVqMDt0Pz-5CakyF2wng; Path=/; HttpOnly; Secure
```
And authenticate using JWTs alone, using the token from `JWT-Cookie`:
```
curl -v -H 'Authorization: Bearer eyJhbGciOiJIUzUxMiJ9.eyJkYXQiOnsiYXVPcmdJRCI6MSwiYXVJRCI6MX19.6ZQba-Co5Ul4wpmU34zXlI75wmasxDfaGRmO3BsOx-ONupX93OBfyYBCIJ3tbWMXKBVVqMDt0Pz-5CakyF2wng' 'http://localhost:3001/bar'
…
< HTTP/1.1 200 OK
```
This program is available as a cabal project
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/jwt-and-basic-auth).

36
doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal Normal file
View file

@ -0,0 +1,36 @@
name: cookbook-jwt-and-basic-auth
version: 0.0.1
synopsis: JWT and basic access authentication cookbook example
description: Using servant-auth to support both JWT-based and basic
authentication.
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
category: Servant
build-type: Simple
cabal-version: >=1.10
executable cookbook-jwt-and-basic-auth
if impl(ghc < 7.10.1)
buildable: False
main-is: JWTAndBasicAuth.lhs
build-depends: base == 4.*
, text >= 1.2
, aeson >= 1.2
, containers >= 0.5
, servant
, servant-client
, servant-server
, servant-auth
, servant-auth-server
, warp >= 3.2
, wai >= 3.2
, http-types >= 0.10
, markdown-unlit >= 0.4
, http-client >= 0.5
, bytestring >= 0.10
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

195
doc/cookbook/structuring-apis/StructuringApis.lhs Normal file
View file

@ -0,0 +1,195 @@
# Structuring APIs
In this recipe, we will see a few simple ways to
structure your APIs by splitting them up into smaller
"sub-APIs" or by sharing common structure between
different parts. Let's start with the usual throat
clearing.
``` haskell
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
import Data.Aeson
import GHC.Generics
import GHC.TypeLits
import Network.Wai.Handler.Warp
import Servant
```
Our application will consist of three different
"sub-APIs", with a few endpoints in each of them.
Our global API is defined as follows.
``` haskell
type API = FactoringAPI
:<|> SimpleAPI "users" User UserId
:<|> SimpleAPI "products" Product ProductId
```
We simply join the three different parts with `:<|>`,
as if each sub-API was just a simple endpoint.
The first part, `FactoringAPI`, shows how we can
"factor out" combinators that are common to several
endpoints, just like we turn `a * b + a * c` into
`a * (b + c)` in algebra.
``` haskell
-- Two endpoints:
-- - GET /x/<some 'Int'>[?y=<some 'Int'>]
-- - POST /x/<some 'Int'>
type FactoringAPI =
"x" :> Capture "x" Int :>
( QueryParam "y" Int :> Get '[JSON] Int
:<|> Post '[JSON] Int
)
{- this is equivalent to:
type FactoringAPI' =
"x" :> Capture "x" Int :> QueryParam "y" Int :> Get '[JSON] Int :<|>
"x" :> Capture "x" Int :> Post '[JSON] Int
-}
```
You can see that both endpoints start with a static
path fragment, `/"x"`, then capture some arbitrary
`Int` until they finally differ. Now, this also has
an effect on the server for such an API, and its type
in particular. While the server for `FactoringAPI'` would
be made of a function of type `Int -> Maybe Int -> Handler Int`
and a function of type `Int -> Handler Int` glued with `:<|>`,
a server for `FactoringAPI` (without the `'`) reflects the
"factorisation" and therefore, `Server FactoringAPI` is
`Int -> (Maybe Int -> Handler Int :<|> Handler Int)`. That is, the
server must be a function that takes an `Int` (the `Capture`) and
returns two values glued with `:<|>`, one of type `Maybe Int -> Handler Int`
and the other of type `Handler Int`. Let's provide such a server
implementation.
_Note_: you can load this module in ghci and ask for the concrete
type that `Server FactoringAPI` "resolves to" by typing
`:kind! Server FactoringAPI`.
``` haskell
factoringServer :: Server FactoringAPI
factoringServer x = getXY :<|> postX
where getXY Nothing = return x
getXY (Just y) = return (x + y)
postX = return (x - 1)
```
Next come the two sub-APIs defined in terms of this `SimpleAPI`
type, but with different parameters. That type is just a good old
Haskell type synonym that abstracts away a pretty common structure in
web services, where you have:
- one endpoint for listing a bunch of entities of some type
- one endpoint for accessing the entity with a given identifier
- one endpoint for creating a new entity
There are many variants on this theme (endpoints for deleting,
paginated listings, etc). The simple definition below reproduces
such a structure, but instead of picking concrete types for
the entities and their identifiers, we simply let the user
of the type decide, by making those types parameters of
`SimpleAPI`. While we're at it, we'll put all our endpoints
under a common prefix that we also take as a parameter.
``` haskell
-- Three endpoints:
-- - GET /<name>
-- - GET /<name>/<some 'i'>
-- - POST /<name>
type SimpleAPI (name :: Symbol) a i = name :>
( Get '[JSON] [a]
:<|> Capture "id" i :> Get '[JSON] a
:<|> ReqBody '[JSON] a :> Post '[JSON] NoContent
)
```
`Symbol` is the [kind](https://wiki.haskell.org/Kind)
of type-level strings, which is what servant uses for
representing static path fragments. We can even provide
a little helper function for creating a server for that API
given one handler for each endpoint as arguments.
``` haskell
simpleServer
:: Handler [a]
-> (i -> Handler a)
-> (a -> Handler NoContent)
-> Server (SimpleAPI name a i)
simpleServer listAs getA postA =
listAs :<|> getA :<|> postA
{- you could alternatively provide such a definition
but with the handlers running in another monad,
or even an arbitrary one!
simpleAPIServer
:: m [a]
-> (i -> m a)
-> (a -> m NoContent)
-> Server (SimpleAPI name a i) m
simpleAPIServer listAs getA postA =
listAs :<|> getA :<|> postA
and use 'hoistServer' on the result of `simpleAPIServer`
applied to your handlers right before you call `serve`.
-}
```
We can use this to define servers for the user and product
related sections of the API.
``` haskell
userServer :: Server (SimpleAPI "users" User UserId)
userServer = simpleServer
(return [])
(\userid -> return $
if userid == 0
then User "john" 64
else User "everybody else" 10
)
(\_user -> return NoContent)
productServer :: Server (SimpleAPI "products" Product ProductId)
productServer = simpleServer
(return [])
(\_productid -> return $ Product "Great stuff")
(\_product -> return NoContent)
```
Finally, some dummy types and the serving part.
``` haskell
type UserId = Int
data User = User { username :: String, age :: Int }
deriving Generic
instance FromJSON User
instance ToJSON User
type ProductId = Int
data Product = Product { productname :: String }
deriving Generic
instance FromJSON Product
instance ToJSON Product
api :: Proxy API
api = Proxy
main :: IO ()
main = run 8080 . serve api $
factoringServer :<|> userServer :<|> productServer
```
This program is available as a cabal project
[here](https://github.com/haskell-servant/servant/tree/master/doc/cookbook/structuring-apis).

24
doc/cookbook/structuring-apis/structuring-apis.cabal Normal file
View file

@ -0,0 +1,24 @@
name: cookbook-structuring-apis
version: 0.1
synopsis: Example that shows how APIs can be structured
homepage: http://haskell-servant.readthedocs.org/
license: BSD3
license-file: ../../../servant/LICENSE
author: Servant Contributors
maintainer: haskell-servant-maintainers@googlegroups.com
build-type: Simple
cabal-version: >=1.10
executable cookbook-structuring-apis
if impl(ghc < 7.10.1)
buildable: False
main-is: StructuringApis.lhs
build-depends: base == 4.*
, aeson >= 1.2
, servant
, servant-server
, warp >= 3.2
, markdown-unlit >= 0.4
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

1
doc/index.rst
View file

@ -19,5 +19,6 @@ All in a type-safe manner.
introduction.rst
tutorial/index.rst
cookbook/index.rst
examples.md
links.rst

23
nix/README.md Normal file
View file

@ -0,0 +1,23 @@
You can use the `shell.nix` from this directory
to build the servant packages or even the tutorial
or cookbook if you want to, optionally.
Just the servant packages:
``` sh
$ nix-shell nix/shell.nix
```
Everything needed for the tutorial and the
cookbook too:
``` sh
$ nix-shell nix/shell.nix --arg tutorial true
```
The `shell.nix` file also supports specifying
a particular ghc version, e.g:
``` sh
$ nix-shell nix/shell.nix --argstr compiler ghcHEAD
```

21
nix/shell.nix Normal file
View file

@ -0,0 +1,21 @@
{ pkgs ? import <nixpkgs> {}
, compiler ? "ghc821"
, tutorial ? false
}:
with pkgs;
let
ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);
docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);
in
stdenv.mkDerivation {
name = "servant-dev";
buildInputs = [ ghc zlib python3 wget ]
++ (if tutorial then [docstuffs postgresql] else []);
shellHook = ''
eval $(grep export ${ghc}/bin/ghc)
export LD_LIBRARY_PATH="${zlib}/lib";
'';
}