{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -F -pgmFhsx2hs #-}
module Clckwrks.MailingList.PreProcess where
import Control.Monad.Reader (mapReaderT)
import Control.Monad.Trans
import Control.Applicative
import Clckwrks (ClckT, ClckState)
import Clckwrks.MailingList.URL (MailingListURL(..))
import Clckwrks.MailingList.Page.Subscribe (emailForm)
import Clckwrks.MailingList.Monad
import Clckwrks.MailingList.Types (Email)
import Clckwrks.Monad (mapClckT, transform, segments)
import Data.Attoparsec.Text.Lazy (Parser, Result(..), char, choice, decimal, parse, skipMany, space, asciiCI, skipMany)
import Data.Monoid (mempty)
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as B
import Happstack.Server (Happstack)
import HSP
import HSP.HTML4 (renderAsHTML)
import Text.Reform (viewForm)
import Text.Reform.Happstack (happstackViewForm, happstackView)
import Text.Reform.HSP.Text (form)
import Web.Routes (showURL)
data MailingListCmd
= SubscribeFormLink
| SubscribeForm
parseAttr :: Text -> Parser ()
parseAttr name =
do skipMany space
asciiCI name
skipMany space
char '='
skipMany space
parseCmd :: Parser MailingListCmd
parseCmd =
choice [ asciiCI (pack "subscription-form-link") *> pure SubscribeFormLink
, asciiCI (pack "subscription-form") *> pure SubscribeForm
]
mailingListCmd :: (MailingListURL -> [(Text, Maybe Text)] -> Text)
-> TL.Text
-> (forall m. (Functor m, MonadIO m, Happstack m) => MailingListT m TL.Text)
mailingListCmd mailingListShowURL txt =
case parse (segments "mailing-list" parseCmd) txt of
(Fail _ _ e) -> return (TL.pack e)
(Done _ segments) ->
do b <- transform (applyCmd mailingListShowURL) segments
return $ B.toLazyText b
-- type MailingListForm = ClckFormT MailingListFormError MailingListM
-- type ClckFormT error m = Form m [Input] error [XMLGenT m XML] ()
-- type MailingListM = ClckT MailingListURL (ReaderT MailingListConfig (ServerPartT IO))
-- type MailingListT m = ClckT MailingListURL (ReaderT MailingListConfig m)
-- type MailingListForm = ClckFormT MailingListFormError MailingListM
applyCmd :: (MailingListURL -> [(Text, Maybe Text)] -> Text)
-> MailingListCmd
-> (forall m. (Functor m, MonadIO m, Happstack m)=> MailingListT m Builder)
applyCmd mailingListShowURL SubscribeFormLink =
do html <- unXMLGenT $ <a href=(mailingListShowURL Subscribe [])>Join our mailing list!</a>
return $ B.fromString $ concat $ lines $ TL.unpack $ renderAsHTML html
{-
In order for this to work, we need to be able to add CSRF cookies. However, at present the preprocessor framework only allows you to transform the body. It runs in `ClckT ClckURL IO TL.Text` not `ClckT ClckURL (ServerPartT IO) TL.Text`
-}
applyCmd mailingListShowURL SubscribeForm =
do url <- showURL Subscribe
view <- happstackViewForm (\hd v -> form url (("formname", "sub"):hd) v) "sub" emailForm
html <- unXMLGenT $ sequence view
return $ B.fromString $ concatMap (concat . lines . TL.unpack . renderAsHTML) html
{-
foo =
do html <- happstackViewForm (form "") "sub" emailForm
return ()
-}