{-# OPTIONS_GHC -fno-warn-orphans -F -pgmF trhsx #-} import Control.Applicative import Control.Applicative.Error import Control.Monad import Control.Monad.Trans import Happstack.Server hiding (ContentType) import Happstack.Server.HSP.HTML import HSP.ServerPartT import HSP import qualified HSX.XMLGenerator as HSX import Text.Formlets -- |An input field with an optional value input :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String input = input' (\n v -> []) -- |An input field with an optional value password :: (XMLGenerator x, Monad v) => Maybe String -> Form [XMLGenT x (HSX.XML x)] v String password = input' (\n v -> []) submit :: (XMLGenerator x, Monad v) => String -> Form [XMLGenT x (HSX.XML x)] v String submit value = input' (\n v -> []) (Just value) main = simpleHTTP nullConf impl impl :: ServerPartT IO Response impl = msum [ do methodM GET let (_, xml, _) = runFormState ([],[]) "" form page $
<% xml %>
, do methodM POST (Just vals') <- getDataFn lookPairs let vals = map (\(n,v) -> (n, Left v)) vals' let (collector, _, _) = runFormState ([], vals) "" form res <- liftIO $ collector case res of (SuccessAt a) -> page $

You entered: <% show a %>

(FailureAt errs) -> do let (_, xml, _) = runFormState (errs, vals) "" form page $
-- <% show vals' %> -- <% show errs %> <% xml %>
] page :: XMLGenT (ServerPartT IO) XML -> ServerPartT IO Response page b = do xml <- unXMLGenT $ Fomlets Demo <% b %> ok (toResponse xml) label str = xml $ [] br :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO () br = xml $ [
] form :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO (String, String) form = (,) <$> (username <* br) <*> pass <* submit "create account" username :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO String username = checkInline (label "Username" *> input Nothing) (\str -> if (length str) < 6 then Failure ["Your username must be at least 6 characters long."] else if (str == "foobar") then Failure ["You may not use the username foobar."] else Success str) (\errs xml -> xml ++ (map (\err -> <% err %>) errs)) pass :: Form [XMLGenT (ServerPartT IO) (HSX.XML (ServerPartT IO))] IO String pass = checkInline ((,) <$> (label "Password" *> password Nothing <* br) <*> (label "Confirm Password" *> password Nothing <* br)) (\(str1, str2) -> if str1 /= str2 then Failure ["Passwords do not match."] else Success str1) (\errs xml -> [

Passwords do not match.

] ++ xml )