Formlets.hs

{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Happstack.Facebook.Formlets 
    ( module HSP.Formlets
    , formletPart
    ) where

import Control.Arrow
import Control.Applicative
import Control.Applicative.Error
import Control.Monad
import Control.Monad.Trans
import Happstack.Server.Extra () -- ServerMonad (XMLGenT m)
-- import Happstack.Server.HSX -- ServerMonad (XMLGenT m)
import Happstack.Facebook.Common(FbXML(..))
import HSP
import HSP.Formlets
import qualified HSX.XMLGenerator as HSX
import Happstack.Server as Happstack
import Text.Formlets

-- ^ 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 -- ^ 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 action handleSuccess handleFailure form = 
        withDataFn lookPairs $ \env ->
            let (collector, formXML,_) = runFormState (map (second Left) env) form
            in 
                 msum [ dir "submit" $ methodSP POST $ XMLGenT $ Happstack.escape . fmap toResponse $ unXMLGenT $ 
                          do res <- liftIO collector
                             case res of
                               (Success a)      -> handleSuccess a
                               (Failure faults) -> handleFailure faults [ <form action=action method="POST" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8" >
                                                                            <% formXML %>
                                                                          </form> ]

                      , methodSP POST $ <form action=action method="POST" enctype="multipart/form-data;charset=UTF-8" accept-charset="UTF-8" >
                                         <% formXML %>
                                        </form>
                      ]