tag -> headers -- ^ extra content for <head> tag, use () for nothing -> body -- ^ contents of <body> tag -> AppT m Response appTemplate title headers body = toResponse <$> <html> <head> <title><% title %>

{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses , ScopedTypeVariables, TypeFamilies, TypeSynonymInstances #-} {-# OPTIONS_GHC -F -pgmFtrhsx #-} module Main where import Control.Applicative import Control.Applicative.Indexed (IndexedFunctor(..), IndexedApplicative(..)) import Control.Monad (msum) import Happstack.Server import Happstack.Server.HSP.HTML () import HSP.ServerPartT import HSP import Text.Reform ( CommonFormError(..), Form, FormError(..), Proof(..), (++>) , (<++), commonFormErrorStr, decimal, prove , transformEither, transform ) import Text.Reform.Happstack import Text.Reform.HSP.String type AppT m = XMLGenT (ServerPartT m) appTemplate :: ( Functor m, Monad m , EmbedAsChild (ServerPartT m) headers , EmbedAsChild (ServerPartT m) body ) => String -- ^ contents of tag -> headers -- ^ extra content for <head> tag, use () for nothing -> body -- ^ contents of <body> tag -> AppT m Response appTemplate title headers body = toResponse <$> <html> <head> <title><% title %> <% headers %> <% body %> type SimpleForm = Form (AppT IO) [Input] AppError [AppT IO (XMLType (ServerPartT IO))] () data AppError = Required | NotANatural String | AppCFE (CommonFormError [Input]) deriving Show instance (Monad m) => EmbedAsChild (ServerPartT m) AppError where asChild Required = asChild $ "required" asChild (NotANatural str) = asChild $ "Could not decode as a positive integer: " ++ str asChild (AppCFE cfe) = asChild $ commonFormErrorStr show cfe instance FormError AppError where type ErrorInputType AppError = [Input] commonFormError = AppCFE data Message = Message { name :: String -- ^ the author's name , title :: String -- ^ the message title , message :: String -- ^ contents of the message } deriving (Eq, Ord, Read, Show) renderMessage :: (Monad m) => Message -> AppT m XML renderMessage msg =

name:: <% name msg %>
title:: <% title msg %>
message:: <% message msg %>

postForm :: SimpleForm Message postForm = Message <$> label "name:" ++> inputText "" <++ br <*> label "title: " ++> inputText "" <++ br <*> (label "message:" <++ br) ++> textarea 80 40 "" <++ br <* inputSubmit "post" postPage :: AppT IO Response postPage = dir "post" $ do result <- happstackEitherForm (form "/post") "post" postForm case result of (Left formHtml) -> appTemplate "post" () formHtml (Right msg) -> appTemplate "Your Message" () $ renderMessage msg postPage2 :: AppT IO Response postPage2 = dir "post2" $ appTemplate "post 2" () $ <% reform (form "/post2") "post2" displayMessage Nothing postForm %> where displayMessage msg = appTemplate "Your Message" () $ renderMessage msg required :: String -> Either AppError String required [] = Left Required required str = Right str validPostForm :: SimpleForm Message validPostForm = Message <$> name <*> title <*> msg <* inputSubmit "post" where name = errorList ++> label "name:" ++> (inputText "" `transformEither` required) <++ br title = errorList ++> label "title:" ++> (inputText "" `transformEither` required) <++ br msg = errorList ++> (label "message:" <++ br) ++> (textarea 80 40 "" `transformEither` required) <++ br validPage :: AppT IO Response validPage = dir "valid" $ appTemplate "valid post" () $ <% reform (form "/valid") "valid" displayMessage Nothing validPostForm %> where displayMessage msg = appTemplate "Your Message" () $ renderMessage msg type ProofForm proof = Form IO [Input] AppError [AppT IO (XMLType (ServerPartT IO))] proof data NotNull = NotNull assertNotNull :: (Monad m) => error -> [a] -> m (Either error [a]) assertNotNull errorMsg [] = return (Left errorMsg) assertNotNull _ xs = return (Right xs) notNullProof :: (Monad m) => error -- ^ error to return if list is empty -> Proof m error NotNull [a] [a] notNullProof errorMsg = Proof { proofName = NotNull , proofFunction = assertNotNull errorMsg } data ValidMessage = ValidMessage mkMessage :: ProofForm (NotNull -> NotNull -> NotNull -> ValidMessage) (String -> String -> String -> Message) mkMessage = ipure (\NotNull NotNull NotNull -> ValidMessage) Message inputText' :: String -> ProofForm NotNull String inputText' initialValue = inputText initialValue `prove` (notNullProof Required) textarea' :: Int -> Int -> String -> ProofForm NotNull String textarea' cols rows initialValue = textarea cols rows initialValue `prove` (notNullProof Required) provenPostForm :: ProofForm ValidMessage Message provenPostForm = mkMessage <<*>> errorList ++> label "name: " ++> inputText' "" <<*>> errorList ++> label "title: " ++> inputText' "" <<*>> errorList ++> label "message: " ++> textarea' 80 40 "" inputInteger :: SimpleForm Integer inputInteger = inputText "" `transform` (decimal NotANatural) main :: IO () main = simpleHTTP nullConf $ unXMLGenT $ do decodeBody (defaultBodyPolicy "/tmp/" 0 10000 10000) msum [ postPage , postPage2 , validPage , do nullDir appTemplate "forms" () $

]