test page

[added formletPart to Happstack.Server.Formlets Jeremy Shaw **20090718205029] { hunk ./src/Happstack/Server/Formlets.hs 3 +{-# OPTIONS_GHC -F -pgmFtrhsx #-} hunk ./src/Happstack/Server/Formlets.hs 6 + , formletPart hunk ./src/Happstack/Server/Formlets.hs 11 -import Control.Applicative.Error (Failing(..)) +import Control.Applicative.Error (Failing(..), ErrorMsg) hunk ./src/Happstack/Server/Formlets.hs 13 -import Control.Monad (msum) -import Control.Monad.Trans (MonadIO, lift) -import Happstack.Server (methodSP, methodM, Method(GET, POST), ok, toResponse, withDataFn, - WebT, Response, ServerPartT(..), anyRequest, notFound, RqData) +import Control.Monad (MonadPlus,msum) +import Control.Monad.Trans (MonadIO(liftIO), MonadTrans(lift)) +import Happstack.Server as Happstack -- (methodSP, methodM, Method(GET, POST), ok, toResponse, withDataFn, + -- WebT, Response, ServerPartT(..), anyRequest, notFound, RqData) hunk ./src/Happstack/Server/Formlets.hs 24 +import HSP +import qualified HSX.XMLGenerator as HSX hunk ./src/Happstack/Server/Formlets.hs 68 +-- ^ turn a formlet into XML+ServerPartT which can be embedded in a larger document +formletPart :: + (EmbedAsChild m xml, EmbedAsAttr m (Attr String String), MonadIO m, Functor m, ToMessage b, FilterMonad Response m, WebMonad Response m, MonadPlus m, ServerMonad m) + => String -- ^ prefix used to ensure field names are unique + -> String -- ^ url to POST form results to + -> (a -> XMLGenT m b) -- ^ handler used when form validates + -> ([ErrorMsg] -> [XMLGenT m (HSX.XML m)] -> XMLGenT m b) -- ^ handler used when form does not validate + -> Form xml IO a -- ^ the formlet + -> XMLGenT m (HSX.XML m) +formletPart prefix action handleSuccess handleFailure form = + withDataFn lookPairsUnicode $ \env -> + let (collector, formXML,_) = runFormState (map (second Left) env) prefix form + in + msum [ methodSP POST $ XMLGenT $ Happstack.escape . fmap toResponse $ unXMLGenT $ + do res <- liftIO collector + case res of + (Success a) -> handleSuccess a + (Failure faults) -> handleFailure faults [ ] + + , + ] +{- +testPart :: ServerPartT IO XML +testPart = + do Happstack.escape (ok $ toResponse "foo") + +fooPart :: ServerPartT IO XML +fooPart = + unXMLGenT $ + + + test page + + +

foo

+ <% XMLGenT barPart %> + + + +barPart :: ServerPartT IO XML +barPart = + Happstack.escape $ fmap toResponse $ unXMLGenT $ + + + test page + + +

bar

+ + + +-} }