[Haskell-cafe] Problem with monadic formlets

[Colin Paul Adams]

>>>>> "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
formlets:

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
  ]
  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 -> 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