operational-0.2.0.0: docs/web/examples/WebSessionState.lhs.html
<!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://www.cs.york.ac.uk/fp/darcs/hscolour/ -->
<title>examples/WebSessionState.lhs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
#!/bin/sh runghc
\begin{code}
<pre><span class='hs-comment'>{------------------------------------------------------------------------------
Control.Monad.Operational
Example:
A CGI script that maintains session state
<a href="http://www.informatik.uni-freiburg.de/~thiemann/WASH/draft.pdf">http://www.informatik.uni-freiburg.de/~thiemann/WASH/draft.pdf</a>
------------------------------------------------------------------------------}</span>
<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types #-}</span>
<span class='hs-keyword'>module</span> <span class='hs-conid'>WebSessionState</span> <span class='hs-keyword'>where</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span><span class='hs-varid'>lift</span><span class='hs-layout'>)</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Char</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Maybe</span>
<span class='hs-comment'>-- external libraries needed</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>H</span>
<span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>CGI</span>
<span class='hs-comment'>{------------------------------------------------------------------------------
This example shows a "magic" implementation of a web session that
looks like it needs to be executed in a running process,
while in fact it's just a CGI script.
The key part is a monad, called "Web" for lack of imagination,
which supports a single operation
ask :: String -> Web String
which sends a simple minded HTML-Form to the web user
and returns his answer.
How does this work? The trick is that all previous answers
are logged in a hidden field of the input form.
The CGI script will simply replays this log when called.
In other words, the user state is stored in the input form.
------------------------------------------------------------------------------}</span>
<span class='hs-keyword'>data</span> <span class='hs-conid'>WebI</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>
<span class='hs-conid'>Ask</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>WebI</span> <span class='hs-conid'>String</span>
<span class='hs-keyword'>type</span> <span class='hs-conid'>Web</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Program</span> <span class='hs-conid'>WebI</span> <span class='hs-varid'>a</span>
<span class='hs-definition'>ask</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Ask</span>
<span class='hs-comment'>-- interpreter</span>
<span class='hs-definition'>runWeb</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Web</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CGI</span> <span class='hs-conid'>CGIResult</span>
<span class='hs-definition'>runWeb</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<span class='hs-comment'>-- fetch log</span>
<span class='hs-varid'>log'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>maybe</span> <span class='hs-conid'>[]</span> <span class='hs-layout'>(</span><span class='hs-varid'>read</span> <span class='hs-varop'>.</span> <span class='hs-varid'>urlDecode</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>getInput</span> <span class='hs-str'>"log"</span>
<span class='hs-comment'>-- maybe append form input</span>
<span class='hs-varid'>f</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>maybe</span> <span class='hs-varid'>id</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>answer</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>answer</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>getInput</span> <span class='hs-str'>"answer"</span>
<span class='hs-keyword'>let</span> <span class='hs-varid'>log</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>f</span> <span class='hs-varid'>log'</span>
<span class='hs-comment'>-- run Web action and output result</span>
<span class='hs-varid'>output</span> <span class='hs-varop'>.</span> <span class='hs-varid'>renderHtml</span> <span class='hs-varop'>=<<</span> <span class='hs-varid'>replay</span> <span class='hs-varid'>m</span> <span class='hs-varid'>log</span> <span class='hs-varid'>log</span>
<span class='hs-keyword'>where</span>
<span class='hs-varid'>replay</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval</span> <span class='hs-varop'>.</span> <span class='hs-varid'>view</span>
<span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ProgramView</span> <span class='hs-conid'>WebI</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CGI</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span>
<span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-varid'>html</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-varid'>html</span>
<span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Ask</span> <span class='hs-varid'>question</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-layout'>(</span><span class='hs-varid'>l</span><span class='hs-conop'>:</span><span class='hs-varid'>ls</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-- replay answer from log</span>
<span class='hs-varid'>replay</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varid'>l</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-varid'>ls</span>
<span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Ask</span> <span class='hs-varid'>question</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-- present HTML page to user</span>
<span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>htmlQuestion</span> <span class='hs-varid'>log</span> <span class='hs-varid'>question</span>
<span class='hs-comment'>-- HTML page with a single form</span>
<span class='hs-definition'>htmlQuestion</span> <span class='hs-varid'>log</span> <span class='hs-varid'>question</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>htmlEnvelope</span> <span class='hs-varop'>$</span> <span class='hs-varid'>p</span> <span class='hs-varop'><<</span> <span class='hs-varid'>question</span> <span class='hs-varop'>+++</span> <span class='hs-varid'>x</span>
<span class='hs-keyword'>where</span>
<span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>form</span> <span class='hs-varop'>!</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>method</span> <span class='hs-str'>"post"</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'><<</span> <span class='hs-layout'>(</span><span class='hs-varid'>textfield</span> <span class='hs-str'>"answer"</span>
<span class='hs-varop'>+++</span> <span class='hs-varid'>submit</span> <span class='hs-str'>"Next"</span> <span class='hs-str'>""</span>
<span class='hs-varop'>+++</span> <span class='hs-varid'>hidden</span> <span class='hs-str'>"log"</span> <span class='hs-layout'>(</span><span class='hs-varid'>urlEncode</span> <span class='hs-varop'>$</span> <span class='hs-varid'>show</span> <span class='hs-varid'>log</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<span class='hs-definition'>htmlMessage</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>htmlEnvelope</span> <span class='hs-varop'>$</span> <span class='hs-varid'>p</span> <span class='hs-varop'><<</span> <span class='hs-varid'>s</span>
<span class='hs-definition'>htmlEnvelope</span> <span class='hs-varid'>html</span> <span class='hs-keyglyph'>=</span>
<span class='hs-varid'>header</span> <span class='hs-varop'><<</span> <span class='hs-varid'>thetitle</span> <span class='hs-varop'><<</span> <span class='hs-str'>"Web Session State demo"</span>
<span class='hs-varop'>+++</span> <span class='hs-varid'>body</span> <span class='hs-varop'><<</span> <span class='hs-varid'>html</span>
<span class='hs-comment'>-- example</span>
<span class='hs-definition'>example</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Web</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span>
<span class='hs-definition'>example</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<span class='hs-varid'>haskell</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>ask</span> <span class='hs-str'>"What's your favorite programming language?"</span>
<span class='hs-keyword'>if</span> <span class='hs-varid'>map</span> <span class='hs-varid'>toLower</span> <span class='hs-varid'>haskell</span> <span class='hs-varop'>/=</span> <span class='hs-str'>"haskell"</span>
<span class='hs-keyword'>then</span> <span class='hs-varid'>message</span> <span class='hs-str'>"Awww."</span>
<span class='hs-keyword'>else</span> <span class='hs-keyword'>do</span>
<span class='hs-varid'>ghc</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>ask</span> <span class='hs-str'>"What's your favorite compiler?"</span>
<span class='hs-varid'>web</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>ask</span> <span class='hs-str'>"What's your favorite monad?"</span>
<span class='hs-varid'>message</span> <span class='hs-varop'>$</span> <span class='hs-str'>"I like "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>ghc</span> <span class='hs-varop'>++</span> <span class='hs-str'>" too, but "</span>
<span class='hs-varop'>++</span> <span class='hs-varid'>web</span> <span class='hs-varop'>++</span> <span class='hs-str'>" is debatable."</span>
<span class='hs-keyword'>where</span>
<span class='hs-varid'>message</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-varop'>.</span> <span class='hs-varid'>htmlMessage</span>
<span class='hs-definition'>main</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runCGI</span> <span class='hs-varop'>.</span> <span class='hs-varid'>runWeb</span> <span class='hs-varop'>$</span> <span class='hs-varid'>example</span>
</pre>\end{code}
</body>
</html>