117 lines
18 KiB
HTML
117 lines
18 KiB
HTML
<?xml version="1.0" encoding="UTF-8"?>
|
|
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
|
|
<html>
|
|
<head>
|
|
<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->
|
|
<title>src/Servant/Server.hs</title>
|
|
<link type='text/css' rel='stylesheet' href='hscolour.css' />
|
|
</head>
|
|
<body>
|
|
<pre><a name="line-1"></a><span class='hs-comment'>{-# LANGUAGE TypeFamilies #-}</span>
|
|
<a name="line-2"></a><span class='hs-comment'>{-# LANGUAGE OverloadedStrings #-}</span>
|
|
<a name="line-3"></a>
|
|
<a name="line-4"></a><span class='hs-comment'>-- | This module lets you implement 'Server's for defined APIs. You'll</span>
|
|
<a name="line-5"></a><span class='hs-comment'>-- most likely just need 'serve'.</span>
|
|
<a name="line-6"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>Servant</span><span class='hs-varop'>.</span><span class='hs-conid'>Server</span> <span class='hs-keyword'>where</span>
|
|
<a name="line-7"></a>
|
|
<a name="line-8"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Monoid</span>
|
|
<a name="line-9"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Proxy</span>
|
|
<a name="line-10"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>HTTP</span><span class='hs-varop'>.</span><span class='hs-conid'>Types</span>
|
|
<a name="line-11"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>Wai</span>
|
|
<a name="line-12"></a>
|
|
<a name="line-13"></a><span class='hs-comment'>-- * Implementing Servers</span>
|
|
<a name="line-14"></a>
|
|
<a name="line-15"></a><a name="serve"></a><span class='hs-comment'>-- | 'serve' allows you to implement an API and produce a wai 'Application'.</span>
|
|
<a name="line-16"></a><span class='hs-comment'>--</span>
|
|
<a name="line-17"></a><span class='hs-comment'>-- Example:</span>
|
|
<a name="line-18"></a><span class='hs-comment'>--</span>
|
|
<a name="line-19"></a><span class='hs-comment'>-- > type MyApi = "books" :> Get [Book] -- GET /books</span>
|
|
<a name="line-20"></a><span class='hs-comment'>-- > :<|> "books" :> ReqBody Book :> Post Book -- POST /books</span>
|
|
<a name="line-21"></a><span class='hs-comment'>-- ></span>
|
|
<a name="line-22"></a><span class='hs-comment'>-- > server :: Server MyApi</span>
|
|
<a name="line-23"></a><span class='hs-comment'>-- > server = listAllBooks :<|> postBook</span>
|
|
<a name="line-24"></a><span class='hs-comment'>-- > where listAllBooks = ...</span>
|
|
<a name="line-25"></a><span class='hs-comment'>-- > postBook book = ...</span>
|
|
<a name="line-26"></a><span class='hs-comment'>-- ></span>
|
|
<a name="line-27"></a><span class='hs-comment'>-- > app :: Application</span>
|
|
<a name="line-28"></a><span class='hs-comment'>-- > app = serve myApi server</span>
|
|
<a name="line-29"></a><span class='hs-comment'>-- ></span>
|
|
<a name="line-30"></a><span class='hs-comment'>-- > main :: IO ()</span>
|
|
<a name="line-31"></a><span class='hs-comment'>-- > main = Network.Wai.Handler.Warp.run 8080 app</span>
|
|
<a name="line-32"></a><span class='hs-definition'>serve</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>HasServer</span> <span class='hs-varid'>layout</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Proxy</span> <span class='hs-varid'>layout</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Server</span> <span class='hs-varid'>layout</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Application</span>
|
|
<a name="line-33"></a><span class='hs-definition'>serve</span> <span class='hs-varid'>p</span> <span class='hs-varid'>server</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>toApplication</span> <span class='hs-layout'>(</span><span class='hs-varid'>route</span> <span class='hs-varid'>p</span> <span class='hs-varid'>server</span><span class='hs-layout'>)</span>
|
|
<a name="line-34"></a>
|
|
<a name="line-35"></a><a name="toApplication"></a><span class='hs-definition'>toApplication</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RoutingApplication</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Application</span>
|
|
<a name="line-36"></a><span class='hs-definition'>toApplication</span> <span class='hs-varid'>ra</span> <span class='hs-varid'>request</span> <span class='hs-varid'>respond</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
|
|
<a name="line-37"></a> <span class='hs-varid'>ra</span> <span class='hs-varid'>request</span> <span class='hs-layout'>(</span><span class='hs-varid'>routingRespond</span> <span class='hs-varop'>.</span> <span class='hs-varid'>routeResult</span><span class='hs-layout'>)</span>
|
|
<a name="line-38"></a> <span class='hs-keyword'>where</span>
|
|
<a name="line-39"></a> <span class='hs-varid'>routingRespond</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Either</span> <span class='hs-conid'>RouteMismatch</span> <span class='hs-conid'>Response</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ResponseReceived</span>
|
|
<a name="line-40"></a> <span class='hs-varid'>routingRespond</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-conid'>NotFound</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
|
|
<a name="line-41"></a> <span class='hs-varid'>respond</span> <span class='hs-varop'>$</span> <span class='hs-varid'>responseLBS</span> <span class='hs-varid'>notFound404</span> <span class='hs-conid'>[]</span> <span class='hs-str'>"not found"</span>
|
|
<a name="line-42"></a> <span class='hs-varid'>routingRespond</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-conid'>WrongMethod</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
|
|
<a name="line-43"></a> <span class='hs-varid'>respond</span> <span class='hs-varop'>$</span> <span class='hs-varid'>responseLBS</span> <span class='hs-varid'>methodNotAllowed405</span> <span class='hs-conid'>[]</span> <span class='hs-str'>"method not allowed"</span>
|
|
<a name="line-44"></a> <span class='hs-varid'>routingRespond</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-conid'>InvalidBody</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
|
|
<a name="line-45"></a> <span class='hs-varid'>respond</span> <span class='hs-varop'>$</span> <span class='hs-varid'>responseLBS</span> <span class='hs-varid'>badRequest400</span> <span class='hs-conid'>[]</span> <span class='hs-str'>"Invalid JSON in request body"</span>
|
|
<a name="line-46"></a> <span class='hs-varid'>routingRespond</span> <span class='hs-layout'>(</span><span class='hs-conid'>Right</span> <span class='hs-varid'>response</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>
|
|
<a name="line-47"></a> <span class='hs-varid'>respond</span> <span class='hs-varid'>response</span>
|
|
<a name="line-48"></a>
|
|
<a name="line-49"></a><a name="RouteMismatch"></a><span class='hs-comment'>-- * Route mismatch</span>
|
|
<a name="line-50"></a><a name="RouteMismatch"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>RouteMismatch</span> <span class='hs-keyglyph'>=</span>
|
|
<a name="line-51"></a> <span class='hs-conid'>NotFound</span> <span class='hs-comment'>-- ^ the usual "not found" error</span>
|
|
<a name="line-52"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>WrongMethod</span> <span class='hs-comment'>-- ^ a more informative "you just got the HTTP method wrong" error</span>
|
|
<a name="line-53"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>InvalidBody</span> <span class='hs-comment'>-- ^ an even more informative "your json request body wasn't valid" error</span>
|
|
<a name="line-54"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>)</span>
|
|
<a name="line-55"></a>
|
|
<a name="line-56"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- | </span>
|
|
<a name="line-57"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- @</span>
|
|
<a name="line-58"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- > mempty = NotFound</span>
|
|
<a name="line-59"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- ></span>
|
|
<a name="line-60"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- > NotFound `mappend` x = x</span>
|
|
<a name="line-61"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- > WrongMethod `mappend` InvalidBody = InvalidBody</span>
|
|
<a name="line-62"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- > WrongMethod `mappend` _ = WrongMethod</span>
|
|
<a name="line-63"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- > InvalidBody `mappend` _ = InvalidBody</span>
|
|
<a name="line-64"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-comment'>-- @</span>
|
|
<a name="line-65"></a><a name="instance%20Monoid%20RouteMismatch"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Monoid</span> <span class='hs-conid'>RouteMismatch</span> <span class='hs-keyword'>where</span>
|
|
<a name="line-66"></a> <span class='hs-varid'>mempty</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>NotFound</span>
|
|
<a name="line-67"></a>
|
|
<a name="line-68"></a> <span class='hs-conid'>NotFound</span> <span class='hs-varop'>`mappend`</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span>
|
|
<a name="line-69"></a> <span class='hs-conid'>WrongMethod</span> <span class='hs-varop'>`mappend`</span> <span class='hs-conid'>InvalidBody</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>InvalidBody</span>
|
|
<a name="line-70"></a> <span class='hs-conid'>WrongMethod</span> <span class='hs-varop'>`mappend`</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>WrongMethod</span>
|
|
<a name="line-71"></a> <span class='hs-conid'>InvalidBody</span> <span class='hs-varop'>`mappend`</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>InvalidBody</span>
|
|
<a name="line-72"></a>
|
|
<a name="line-73"></a><a name="RouteResult"></a><span class='hs-comment'>-- | A wrapper around @'Either' 'RouteMismatch' a@.</span>
|
|
<a name="line-74"></a><a name="RouteResult"></a><span class='hs-keyword'>newtype</span> <span class='hs-conid'>RouteResult</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span>
|
|
<a name="line-75"></a> <span class='hs-conid'>RR</span> <span class='hs-layout'>{</span> <span class='hs-varid'>routeResult</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Either</span> <span class='hs-conid'>RouteMismatch</span> <span class='hs-varid'>a</span> <span class='hs-layout'>}</span>
|
|
<a name="line-76"></a> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span> <span class='hs-conid'>Show</span><span class='hs-layout'>)</span>
|
|
<a name="line-77"></a>
|
|
<a name="line-78"></a><a name="failWith"></a><span class='hs-definition'>failWith</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteMismatch</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteResult</span> <span class='hs-varid'>a</span>
|
|
<a name="line-79"></a><span class='hs-definition'>failWith</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>RR</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Left</span>
|
|
<a name="line-80"></a>
|
|
<a name="line-81"></a><a name="succeedWith"></a><span class='hs-definition'>succeedWith</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RouteResult</span> <span class='hs-varid'>a</span>
|
|
<a name="line-82"></a><span class='hs-definition'>succeedWith</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>RR</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Right</span>
|
|
<a name="line-83"></a>
|
|
<a name="line-84"></a><a name="isMismatch"></a><span class='hs-definition'>isMismatch</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>RouteResult</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>
|
|
<a name="line-85"></a><span class='hs-definition'>isMismatch</span> <span class='hs-layout'>(</span><span class='hs-conid'>RR</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>True</span>
|
|
<a name="line-86"></a><span class='hs-definition'>isMismatch</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>False</span>
|
|
<a name="line-87"></a>
|
|
<a name="line-88"></a><a name="instance%20Monoid%20(RouteResult%20a)"></a><span class='hs-comment'>-- | If we get a `Right`, it has precedence over everything else.</span>
|
|
<a name="line-89"></a><a name="instance%20Monoid%20(RouteResult%20a)"></a><span class='hs-comment'>--</span>
|
|
<a name="line-90"></a><a name="instance%20Monoid%20(RouteResult%20a)"></a><span class='hs-comment'>-- This in particular means that if we could get several 'Right's,</span>
|
|
<a name="line-91"></a><a name="instance%20Monoid%20(RouteResult%20a)"></a><span class='hs-comment'>-- only the first we encounter would be taken into account.</span>
|
|
<a name="line-92"></a><a name="instance%20Monoid%20(RouteResult%20a)"></a><span class='hs-keyword'>instance</span> <span class='hs-conid'>Monoid</span> <span class='hs-layout'>(</span><span class='hs-conid'>RouteResult</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
|
|
<a name="line-93"></a> <span class='hs-varid'>mempty</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>RR</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Left</span> <span class='hs-varid'>mempty</span>
|
|
<a name="line-94"></a>
|
|
<a name="line-95"></a> <span class='hs-conid'>RR</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-varop'>`mappend`</span> <span class='hs-conid'>RR</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>RR</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Left</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span> <span class='hs-varop'><></span> <span class='hs-varid'>y</span><span class='hs-layout'>)</span>
|
|
<a name="line-96"></a> <span class='hs-conid'>RR</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varop'>`mappend`</span> <span class='hs-conid'>RR</span> <span class='hs-layout'>(</span><span class='hs-conid'>Right</span> <span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>RR</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Right</span> <span class='hs-varid'>y</span>
|
|
<a name="line-97"></a> <span class='hs-varid'>r</span> <span class='hs-varop'>`mappend`</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>r</span>
|
|
<a name="line-98"></a>
|
|
<a name="line-99"></a><a name="RoutingApplication"></a><span class='hs-keyword'>type</span> <span class='hs-conid'>RoutingApplication</span> <span class='hs-keyglyph'>=</span>
|
|
<a name="line-100"></a> <span class='hs-conid'>Request</span> <span class='hs-comment'>-- ^ the request, the field 'pathInfo' may be modified by url routing</span>
|
|
<a name="line-101"></a> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-conid'>RouteResult</span> <span class='hs-conid'>Response</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ResponseReceived</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>ResponseReceived</span>
|
|
<a name="line-102"></a>
|
|
<a name="line-103"></a><span class='hs-keyword'>class</span> <span class='hs-conid'>HasServer</span> <span class='hs-varid'>layout</span> <span class='hs-keyword'>where</span>
|
|
<a name="line-104"></a> <span class='hs-keyword'>type</span> <span class='hs-conid'>Server</span> <span class='hs-varid'>layout</span> <span class='hs-keyglyph'>::</span> <span class='hs-varop'>*</span>
|
|
<a name="line-105"></a> <span class='hs-varid'>route</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Proxy</span> <span class='hs-varid'>layout</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Server</span> <span class='hs-varid'>layout</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>RoutingApplication</span>
|
|
</pre></body>
|
|
</html>
|