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 qualified Data.ByteString.Lazy.UTF8       as LU (toString, fromString)
import Data.Maybe (fromMaybe)
-- 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 as F

-- ^ 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, HasRqData 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 lookEnv $ \env ->
            let (collector, formXML,_) = runFormState 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>
                      ]

lookEnv :: RqData Env
lookEnv =
    do (query,body,_) <- askRqEnv
       return $ map (\(name, value) ->
                     case inputValue value of
                       (Left fileContentsPath) ->
                           (name, Right $ (File { content       = LU.fromString $ fileContentsPath -- this is not really correct, it is expecting the contents of the file not the path to the saved contents. Though perhaps this is better
                                                , fileName      = fromMaybe "" (inputFilename value)
                                                , F.contentType = F.ContentType { F.ctType       = Happstack.ctType       (inputContentType value)
                                                                                , F.ctSubtype    = Happstack.ctSubtype    (inputContentType value)
                                                                                , F.ctParameters = Happstack.ctParameters (inputContentType value)
                                                                                }
                                                }))
                       (Right contents) ->
                           (name, Left $ LU.toString contents)) (query ++ body)