{-# 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 $
, 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 $ ] page :: XMLGenT (ServerPartT IO) XML -> ServerPartT IO Response page b = do xml <- unXMLGenT $Passwords do not match.
] ++ xml )