Difference between revisions of "Web/Libraries/Formlets"
SimonHengel (talk | contribs) (Added reference to Chris Done) |
(Updated to use happstack-0.2.1; may not be fully idiomatic) |
||
Line 47: | Line 47: | ||
[http://hackage.haskell.org/cgi-bin/hackage-scripts/package/formlets Formlets] | [http://hackage.haskell.org/cgi-bin/hackage-scripts/package/formlets Formlets] | ||
and | and | ||
− | [http://hackage.haskell.org | + | [http://hackage.haskell.org/package/happstack-server Happstack-Server]. |
=== Prepare your system === | === Prepare your system === | ||
− | First install Formlets and | + | First install Formlets and Happstack-Server on your system: |
<pre> | <pre> | ||
− | $ cabal install formlets | + | $ cabal install formlets happstack-server |
</pre> | </pre> | ||
Line 62: | Line 62: | ||
module Main where | module Main where | ||
− | import | + | import Control.Applicative |
− | + | import Control.Applicative.Error | |
− | import Control.Applicative.Error | + | import Control.Applicative.State |
− | import Control.Applicative.State | + | import Data.List as List |
− | import Text.XHtml.Strict.Formlets | + | import Happstack.Server |
− | import Text.XHtml.Strict ((+++), (<<), (!)) | + | import Text.Formlets |
− | import qualified Text.XHtml.Strict as X | + | import Text.XHtml.Strict.Formlets |
− | + | import Text.XHtml.Strict ((+++),(<<),(!)) | |
+ | import qualified Text.XHtml.Strict as X | ||
type MyForm a = XHtmlForm IO a | type MyForm a = XHtmlForm IO a | ||
− | data Date = Date {month :: Integer, day :: Integer} deriving Show | + | data Date = Date {month :: Integer, day :: Integer} |
+ | deriving Show | ||
validDate :: Date -> Bool | validDate :: Date -> Bool | ||
validDate (Date m d) = m `elem` [1..12] && d `elem` [1..31] | validDate (Date m d) = m `elem` [1..12] && d `elem` [1..31] | ||
− | dateComponent :: MyForm Date | + | dateComponent :: MyForm Date |
dateComponent = Date <$> inputInteger (Just 1) <*> inputInteger (Just 16) | dateComponent = Date <$> inputInteger (Just 1) <*> inputInteger (Just 16) | ||
dateFull :: MyForm Date | dateFull :: MyForm Date | ||
− | dateFull | + | dateFull = dateComponent `check` ensure validDate "This is not a valid date" |
− | handleDate :: | + | handleDate :: ServerPartT IO Response |
handleDate = withForm "date" dateFull showErrorsInline (\d -> okHtml $ show d) | handleDate = withForm "date" dateFull showErrorsInline (\d -> okHtml $ show d) | ||
− | data User = User {name :: String, pass :: String, birthdate :: Date} deriving Show | + | data User = User {name :: String, pass :: String, birthdate :: Date} |
+ | deriving Show | ||
userFull :: MyForm User | userFull :: MyForm User | ||
Line 94: | Line 97: | ||
handleUser = withForm "user" userFull showErrorsInline (\u -> okHtml $ show u) | handleUser = withForm "user" userFull showErrorsInline (\u -> okHtml $ show u) | ||
− | withForm :: String -> MyForm a -> (X.Html -> [String] -> | + | withForm |
− | withForm name frm handleErrors handleOk = | + | :: String |
− | + | -> MyForm a | |
− | + | -> (X.Html -> [String] -> ServerPartT IO Response) | |
− | + | -> (a -> ServerPartT IO Response) | |
− | + | -> ServerPartT IO Response | |
+ | withForm name frm handleErrors handleOk = dir name $ msum | ||
+ | [ methodSP GET $ createForm [] frm >>= okHtml | ||
+ | , withDataFn lookPairs $ \d -> | ||
+ | methodSP POST $ handleOk' $ simple d | ||
] | ] | ||
− | where handleOk' d = do let (extractor, html, _) = runFormState d "" frm | + | where |
− | + | handleOk' d = do | |
− | + | let (extractor, html, _) = runFormState d "" frm | |
− | + | v <- liftIO extractor | |
− | + | case v of | |
− | + | Failure faults -> do | |
− | + | f <- createForm d frm | |
+ | handleErrors f faults | ||
+ | Success s -> handleOk s | ||
+ | simple d = List.map (\(k,v) -> (k, Left v)) d | ||
− | showErrorsInline :: X.Html -> [String] -> | + | showErrorsInline :: X.Html -> [String] -> ServerPartT IO Response |
showErrorsInline renderedForm errors = | showErrorsInline renderedForm errors = | ||
okHtml $ X.toHtml (show errors) +++ renderedForm | okHtml $ X.toHtml (show errors) +++ renderedForm | ||
− | createForm :: Env -> MyForm a -> | + | createForm :: Env -> MyForm a -> ServerPartT IO X.Html |
createForm env frm = do | createForm env frm = do | ||
let (extractor, xml, endState) = runFormState env "" frm | let (extractor, xml, endState) = runFormState env "" frm | ||
Line 119: | Line 129: | ||
return $ X.form ! [X.method "POST"] << (xml' +++ X.submit "submit" "Submit") | return $ X.form ! [X.method "POST"] << (xml' +++ X.submit "submit" "Submit") | ||
− | okHtml :: (X.HTML a) => a -> | + | okHtml :: (X.HTML a) => a -> ServerPartT IO Response |
okHtml content = ok $ toResponse $ htmlPage $ content | okHtml content = ok $ toResponse $ htmlPage $ content | ||
htmlPage :: (X.HTML a) => a -> X.Html | htmlPage :: (X.HTML a) => a -> X.Html | ||
− | htmlPage content = (X.header | + | htmlPage content = (X.header << (X.thetitle << "Testing forms")) |
+ | +++ (X.body << content) | ||
+ | |||
+ | main = simpleHTTP (nullConf {port = 5000}) (handleDate `mplus` handleUser) | ||
+ | |||
− | |||
</haskell> | </haskell> | ||
=== Running the example === | === Running the example === | ||
− | Start up the | + | Start up the Happstack server with |
<pre> | <pre> | ||
$ runhaskell Main.hs | $ runhaskell Main.hs |
Revision as of 02:48, 10 August 2009
Contents
Introduction
Formlets are a way of building HTML forms that are type-safe, handle errors, abstract and are easy to combine into bigger forms. Here's an example:
name :: Form String
name = input Nothing
The input function takes a Maybe String, and produces a XHtmlForm String. The Maybe String is used for default values. If you give it a nothing, it won't have a default value. If you pass in a (Just "value"), it will be pre-populated with the value "value".
You can easily combine formlets using the Applicative Functor combinators. Suppose you have a User-datatype:
data User = User {name :: String, age :: Integer, email :: String}
You can then build a form that produces a user:
userForm :: Form User
userForm = User <$> name <*> inputInteger <*> input Nothing
You can also have more advanced widgets, like a radio-choice, that's where you use enumRadio:
enumRadio :: (Monad m, Enum a) => [(a, String)] -> Maybe a -> Form a
So it asks for a list of pairs with a value and the corresponding label, a possible default-value and it will return something of type a.
chooseBool :: Form Bool
chooseBool = enumRadio [(True, "Yes"), (False, "No")] True
Now we have a widget for booleans that we can use everywhere in our forms!
The basics
Simple validation
Monadic validation
A working example
Below is a self-contained example that uses Formlets and Happstack-Server.
Prepare your system
First install Formlets and Happstack-Server on your system:
$ cabal install formlets happstack-server
The example code
Put the following in a file called Main.hs
:
module Main where
import Control.Applicative
import Control.Applicative.Error
import Control.Applicative.State
import Data.List as List
import Happstack.Server
import Text.Formlets
import Text.XHtml.Strict.Formlets
import Text.XHtml.Strict ((+++),(<<),(!))
import qualified Text.XHtml.Strict as X
type MyForm a = XHtmlForm IO a
data Date = Date {month :: Integer, day :: Integer}
deriving Show
validDate :: Date -> Bool
validDate (Date m d) = m `elem` [1..12] && d `elem` [1..31]
dateComponent :: MyForm Date
dateComponent = Date <$> inputInteger (Just 1) <*> inputInteger (Just 16)
dateFull :: MyForm Date
dateFull = dateComponent `check` ensure validDate "This is not a valid date"
handleDate :: ServerPartT IO Response
handleDate = withForm "date" dateFull showErrorsInline (\d -> okHtml $ show d)
data User = User {name :: String, pass :: String, birthdate :: Date}
deriving Show
userFull :: MyForm User
userFull = User <$> input Nothing <*> password Nothing <*> dateFull
handleUser = withForm "user" userFull showErrorsInline (\u -> okHtml $ show u)
withForm
:: String
-> MyForm a
-> (X.Html -> [String] -> ServerPartT IO Response)
-> (a -> ServerPartT IO Response)
-> ServerPartT IO Response
withForm name frm handleErrors handleOk = dir name $ msum
[ methodSP GET $ createForm [] frm >>= okHtml
, withDataFn lookPairs $ \d ->
methodSP POST $ handleOk' $ simple d
]
where
handleOk' d = do
let (extractor, html, _) = runFormState d "" frm
v <- liftIO extractor
case v of
Failure faults -> do
f <- createForm d frm
handleErrors f faults
Success s -> handleOk s
simple d = List.map (\(k,v) -> (k, Left v)) d
showErrorsInline :: X.Html -> [String] -> ServerPartT IO Response
showErrorsInline renderedForm errors =
okHtml $ X.toHtml (show errors) +++ renderedForm
createForm :: Env -> MyForm a -> ServerPartT IO X.Html
createForm env frm = do
let (extractor, xml, endState) = runFormState env "" frm
xml' <- liftIO xml
return $ X.form ! [X.method "POST"] << (xml' +++ X.submit "submit" "Submit")
okHtml :: (X.HTML a) => a -> ServerPartT IO Response
okHtml content = ok $ toResponse $ htmlPage $ content
htmlPage :: (X.HTML a) => a -> X.Html
htmlPage content = (X.header << (X.thetitle << "Testing forms"))
+++ (X.body << content)
main = simpleHTTP (nullConf {port = 5000}) (handleDate `mplus` handleUser)
Running the example
Start up the Happstack server with
$ runhaskell Main.hs
and point your web browser at http://localhost:5000/date/ and http://localhost:5000/user/.