One of the most low-level parts of web development is building forms. You need to code to both build forms and handle them, and manually sync that code to make sure the names match up. In this post, we will use <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/formlets">formlets</a> and <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HAppS-Server">HAppS-Server</a> to solve those problems. Formlets are a way to compose parts of a form into a complete form, without having to worry about names, types and validations.

> module Main where
> import HAppS.Server
> import Control.Applicative
> import Control.Applicative.Error
> import Control.Applicative.State
> import Text.Formlets
> import Text.XHtml.Strict ((+++), (<<), (!))
> import qualified Text.XHtml.Strict as X
> import qualified Data.Map as M


First of all, we are going to build a form that accepts a date (consisting of two parts: a month and a day). Our datatype reflects this:

> data Date = Date {month :: Integer, day :: Integer} deriving Show

We want to prevent the user from entering weird dates, so 

> validDate :: Date -> Bool
> validDate (Date m d) = m `elem` [1..12] && d `elem` [1..31]

Now we are going to write a FailingForm that reads two integers, and uses them to create a real Date. Using applicative style, we can nicely express this:
 
> dateComponent :: FailingForm Date
> dateComponent = Date <$> inputIntegerF (Just 1) <*> inputIntegerF (Just 16)

We can now combine dateComponent and validDate to create a validating Date component:

> dateFull :: FailingForm Date
> dateFull   = dateComponent `check` ensure validDate "This is not a valid date"

Finally, if we use some helper functions we can create a ServerPart, which is everything HAppS needs in order to run:

> handleDate :: [ServerPart Response]
> handleDate = withForm "date" dateFull showErrorsInline (\d -> okHtml $ show d)

This will show a form, and if you press "Submit", it will make sure all validations pass, and show you the value. If the form doesn't get validated, it will show a list of errors, and you can change your previously entered values.

To demonstrate the compositionality of formlets, we will create a User datatype, and use the date-formlet to let the user enter a birthDate:

> data User = User {name :: String, password :: String, birthdate :: Date} deriving Show
> 
> userFull :: FailingForm User
> userFull = User <$> inputF Nothing <*> passwordF Nothing <*> dateFull

And that's all there is to it! We now have user form that asks for a name, a password and a birthdate. We can use the withForm function again to handle the GET and POST:

> handleUser = withForm "user" userFull showErrorsInline (\u -> okHtml $ show u)

Finally, here are all the helper functions we used:

> withForm :: String -> FailingForm a -> (X.Html -> [String] -> Web Response) -> (a -> Web Response) -> [ServerPart Response]
> withForm name frm handleErrors handleOk = 
>   [dir name 
>      [ method GET           $ okHtml $ createForm [] frm
>      , withDataFn lookPairs $ \d -> [method POST $ handleOk' d]
>      ]
>   ]
>   where ((extractor, html), endState) = runFormState [] frm 0
>         handleOk' d = case extractor d of
>                         Failure faults -> handleErrors (createForm d frm) faults
>                         Success s      -> handleOk s
> 
> showErrorsInline :: X.Html -> [String] -> Web Response
> showErrorsInline renderedForm errors =
>   okHtml $ X.toHtml (show errors) +++ renderedForm
> 
> createForm :: Env -> FailingForm a -> X.Html
> createForm env frm =
>   X.form ! [X.method "POST"] << (xml +++ X.submit "submit" "Submit")
>    where ((extractor, xml), endState) = runFormState env frm 0
> 
> okHtml :: (X.HTML a) => a -> Web 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 ++ handleUser)