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

{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeSynonymInstances, QuasiQuotes, OverloadedStrings #-} module Main where import Control.Applicative import Control.Applicative.Indexed (IndexedFunctor(..), IndexedApplicative(..)) import Control.Monad (msum) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as Lazy import qualified Data.Text as Strict import Happstack.Server import Happstack.Server.XMLGenT () import Happstack.Server.HSP.HTML () import HSP import HSP.Monad (HSPT(..)) import Language.Haskell.HSX.QQ (hsx) import Text.Reform ( CommonFormError(..), Form, FormError(..), Proof(..), (++>) , (<++), commonFormErrorStr, decimal, prove , transformEither, transform ) import Text.Reform.Happstack import Text.Reform.HSP.Text type AppT m = XMLGenT (HSPT XML (ServerPartT m)) type AppT' m = HSPT XML (ServerPartT m) appTemplate :: ( Functor m, Monad m , EmbedAsChild (AppT' m) headers , EmbedAsChild (AppT' m) body ) => Text -- ^ 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 <$> [hsx| <html> <head> <title><% title %> <% headers %> <% body %> |] type SimpleForm = Form (AppT IO) [Input] AppError [AppT IO XML] () data AppError = Required | NotANatural String | AppCFE (CommonFormError [Input]) deriving Show instance (Functor m, Monad m) => EmbedAsChild (AppT' 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 (Functor m, Monad m) => EmbedAsChild (AppT' m) Strict.Text where asChild t = asChild (Lazy.fromStrict t) instance (Functor m, Monad m) => EmbedAsAttr (AppT' m) (Attr Text Strict.Text) where asAttr (n := v) = asAttr (n := Lazy.fromStrict v) instance FormError AppError where type ErrorInputType AppError = [Input] commonFormError = AppCFE data Message = Message { name :: Strict.Text -- ^ the author's name , title :: Strict.Text -- ^ the message title , message :: Strict.Text -- ^ contents of the message } deriving (Eq, Ord, Read, Show) renderMessage :: ( Functor m , Monad m , EmbedAsChild (AppT' m) Strict.Text) => Message -> AppT m XML renderMessage msg = [hsx|

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

|] postForm :: SimpleForm Message postForm = Message <$> labelText "name:" ++> inputText "" <++ br <*> labelText "title: " ++> inputText "" <++ br <*> (labelText "message:" <++ br) ++> textarea 80 40 "" <++ br <* inputSubmit "post" postPage :: AppT IO Response postPage = dir "post" $ do let action = "/post" :: Text result <- happstackEitherForm (form action) "post" postForm case result of (Left formHtml) -> appTemplate "post" () formHtml (Right msg) -> appTemplate "Your Message" () $ renderMessage msg postPage2 :: AppT IO Response postPage2 = dir "post2" $ let action = ("/post2" :: Text) in appTemplate "post 2" () $[hsx| <% reform (form action) "post2" displayMsg Nothing postForm %> |] where displayMsg msg = appTemplate "Your Message" () $ renderMessage msg required :: Strict.Text -> Either AppError Strict.Text required txt | Strict.null txt = Left Required | otherwise = Right txt validPostForm :: SimpleForm Message validPostForm = Message <$> name <*> title <*> msg <* inputSubmit "post" where name = errorList ++> labelText "name:" ++> (inputText "" `transformEither` required) <++ br title = errorList ++> labelText "title:" ++> (inputText "" `transformEither` required) <++ br msg = errorList ++> (labelText "message:" <++ br) ++> (textarea 80 40 "" `transformEither` required) <++ br validPage :: AppT IO Response validPage = dir "valid" $ let action = "/valid" :: Text in appTemplate "valid post" () $ [hsx| <% reform (form action) "valid" displayMsg Nothing validPostForm %> |] where displayMsg msg = appTemplate "Your Message" () $ renderMessage msg type ProofForm proof = Form IO [Input] AppError [AppT IO XML] proof data NotNull = NotNull assertNotNull :: (Monad m) => error -> Strict.Text -> m (Either error Strict.Text) assertNotNull errorMsg txt | Strict.null txt = return (Left errorMsg) | otherwise = return (Right txt) notNullProof :: (Monad m) => error -- ^ error to return if list is empty -> Proof m error NotNull Strict.Text Strict.Text notNullProof errorMsg = Proof { proofName = NotNull , proofFunction = assertNotNull errorMsg } data ValidMessage = ValidMessage mkMessage :: ProofForm (NotNull -> NotNull -> NotNull -> ValidMessage) (Strict.Text -> Strict.Text -> Strict.Text -> Message) mkMessage = ipure (\NotNull NotNull NotNull -> ValidMessage) Message inputText' :: Strict.Text -> ProofForm NotNull Strict.Text inputText' initialValue = inputText initialValue `prove` (notNullProof Required) textarea' :: Int -- ^ cols -> Int -- ^ rows -> Strict.Text -- ^ initial value -> ProofForm NotNull Strict.Text textarea' cols rows initialValue = textarea cols rows initialValue `prove` (notNullProof Required) provenPostForm :: ProofForm ValidMessage Message provenPostForm = mkMessage <<*>> errorList ++> labelText "name: " ++> inputText' "" <<*>> errorList ++> labelText "title: " ++> inputText' "" <<*>> errorList ++> labelText "message: " ++> textarea' 80 40 "" main :: IO () main = simpleHTTP nullConf $ unHSPT $ unXMLGenT $ do decodeBody (defaultBodyPolicy "/tmp/" 0 10000 10000) msum [ postPage , postPage2 , validPage , do nullDir appTemplate "forms" () $ [hsx|

|] ]