[Haskell-cafe] Problem with monadic formlets

Colin Paul Adams colin at colina.demon.co.uk
Fri Aug 28 02:06:05 EDT 2009

>>>>> "Jeremy" == Jeremy Shaw <jeremy at n-heptane.com> writes:

    Jeremy> Hello, I hacked your code into a runnable example, and it
    Jeremy> seems to work for me.

    Jeremy> Which looks correct to me. Your code looks fine to me as
    Jeremy> well... Perhaps the error is not in the code you pasted,
    Jeremy> but somewhere else. I am running on an older, and somewhat
    Jeremy> forked version of Formlets, so there could also be a bug
    Jeremy> in the new code I guess. Though, that seems unlikely. But
    Jeremy> it is worth noting that we are not using the same version
    Jeremy> of the formlets library.

I did some debugging in ghci, but was unable to step through the
ensure and check routines, which is where the apparent data corruprion
is occurring. I am suspecting a bug in the formlets library (I have
version 0.6).

So I have created a slightly cut-down (no database involved) complete
working program. Can you see if this works ok with your version of

module Main where

import Control.Applicative
import Control.Applicative.Error
import Control.Applicative.State
import Data.List as List
import Text.Formlets
import qualified Text.XHtml.Strict.Formlets as F
import qualified Text.XHtml.Strict as X
import Text.XHtml.Strict ((+++), (<<))
import Happstack.Server

type XForm a = F.XHtmlForm IO a

data Registration = Registration { regUser :: String
                                 , regPass :: String }
                                 deriving Show

handleRegistration :: ServerPartT IO Response
handleRegistration = withForm "register" register showErrorsInline (\u -> okHtml $ regUser u ++ " is successfully registered")

withForm :: String -> XForm 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
    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 -> XForm a -> ServerPartT IO X.Html
createForm env frm = do
  let (extractor, xml, endState) = runFormState env frm
  xml' <- liftIO xml
  return $ X.form X.! [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)

register :: XForm Registration
register = Registration <$> user <*> passConfirmed

user :: XForm String
user = pure_user `F.checkM` F.ensureM valid error where
    valid name = return True
    error = "Username already exists in the database!"
pure_user :: XForm String
pure_user = input `F.check` F.ensure valid error where
    input = "Username" `label` F.input Nothing
    valid = (>= 3) . length
    error = "Username must be three characters or longer."

passConfirmed :: XForm String
passConfirmed = fst <$> passwords `F.check` F.ensure equal error where
    passwords = (,) <$> pass "Password" <*> pass "Password (confirm)"
    equal (a, b) = a == b
    error = "The entered passwords do not match!"

pass :: String -> XForm String
pass caption = input `F.check` F.ensure valid error where
    input = caption `label` F.password Nothing
    valid = (>=6) . length
    error = "Password must be six characters or longer."

label :: String -> XForm String -> XForm String
label l = F.plug (\xhtml -> X.p << (X.label << (l ++ ": ") +++ xhtml))

main = simpleHTTP (nullConf {port = 9959}) handleRegistration

Colin Adams
Preston Lancashire

More information about the Haskell-Cafe mailing list