#!/bin/sh runghc
\begin{code}
module WebSessionState where
import Control.Monad
import Control.Monad.Operational
import Control.Monad.Trans hiding (lift)
import Data.Char
import Data.Maybe
import Text.Html as H
import Network.CGI
data WebI a where
Ask :: String -> WebI String
type Web a = Program WebI a
ask = singleton . Ask
runWeb :: Web H.Html -> CGI CGIResult
runWeb m = do
log' <- maybe [] (read . urlDecode) `liftM` getInput "log"
f <- maybe id (\answer -> (++ [answer])) `liftM` getInput "answer"
let log = f log'
output . renderHtml =<< replay m log log
where
replay = eval . view
eval :: ProgramView WebI H.Html -> [String] -> [String] -> CGI H.Html
eval (Return html) log _ = return html
eval (Ask question :>>= k) log (l:ls) =
replay (k l) log ls
eval (Ask question :>>= k) log [] =
return $ htmlQuestion log question
htmlQuestion log question = htmlEnvelope $ p << question +++ x
where
x = form ! [method "post"] << (textfield "answer"
+++ submit "Next" ""
+++ hidden "log" (urlEncode $ show log))
htmlMessage s = htmlEnvelope $ p << s
htmlEnvelope html =
header << thetitle << "Web Session State demo"
+++ body << html
example :: Web H.Html
example = do
haskell <- ask "What's your favorite programming language?"
if map toLower haskell /= "haskell"
then message "Awww."
else do
ghc <- ask "What's your favorite compiler?"
web <- ask "What's your favorite monad?"
message $ "I like " ++ ghc ++ " too, but "
++ web ++ " is debatable."
where
message = return . htmlMessage
main = runCGI . runWeb $ example
\end{code}