Templates.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Network.Mail.Newsletter.Web.Templates
 ( NlTemplates(..)
 , HasNlTemplates(..)
 , defTemplates
 , defSubStart
 , defSubAwaitEmail
 , defOptInEmail
 , defConf
 , defConfed
 , defUnsubConf
 , defUnsubbed
 ) where

import           Control.Lens
import           Control.Monad.Reader
import           Data.Text (Text)
import qualified Data.Text.Lazy as TL
import           Network.Mail.Mime
import           Network.Mail.Newsletter.Web.API
import           Servant
import           Text.Blaze.Html
import           Text.Blaze.Html.Renderer.Text (renderHtml)
import qualified Text.Blaze.Html5 as HTML5
import qualified Text.Blaze.Html5.Attributes as HTML5A
import           Text.Printf

data NlTemplates m
 = NlTemplates
   { _subStartPage      :: (HasApiRoot m)
                        => Text -> Text -> Text -> Text -> m Html
     -- ^ The sign up start form page.
   , _subStartSubmitted :: (HasApiRoot m)
                        => Address -> m Html
     -- ^ The page the sign up form lands at.
   , _optInEmail        :: (HasApiRoot m)
                        => Address -> m (Address -> Mail)
     -- ^ Given the potential new subsriber, generate the opt-in email to them.
   , _confirmStart      :: (HasApiRoot m)
                        => Address -> m Html
     -- ^ The page people land on from the email to confirm they want to subscribe.
   , _confirmConfirmed  :: (HasApiRoot m)
                        => Address -> m Html
     -- ^ The page that confirms they have completed subscribing.
   , _unsubConfirmTempl :: (HasApiRoot m)
                        => Address -> m Html
     -- ^ A page with an unsubscribe button for a given user.
     --   The URI is the form POST destination, the Address is
     --   the addres of the unsubscribing user.
   , _unsubTempl        :: (HasApiRoot m)
                        => Address -> m Html
     -- ^ The page notifying you of sucessful unsubscription.
   }

makeClassy ''NlTemplates

defTemplates :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m
                ,IsElem NewsletterSubConfirmGet (ApiRoot m))
             => NlTemplates m
defTemplates =
  NlTemplates
  { _subStartPage      = defSubStart (pure ())
  , _subStartSubmitted = defSubAwaitEmail
  , _optInEmail        = defOptInEmail "Newsletter signup confirmation email"
  , _confirmStart      = defConf
  , _confirmConfirmed  = defConfed
  , _unsubConfirmTempl = defUnsubConf
  , _unsubTempl        = defUnsubbed
  }

defSubStart :: Monad m => Html -> Text -> Text -> Text -> Text -> m Html
defSubStart desc f dk gk gv = do
  pure . HTML5.docTypeHtml $ do
    HTML5.head $ pure ()
    HTML5.body $ do
      desc
      HTML5.form ! HTML5A.method "POST" $ do
        HTML5.input ! HTML5A.type_ "email" ! HTML5A.name "email"
        HTML5.input ! HTML5A.type_ "hidden" ! HTML5A.name "f"
                                            ! HTML5A.value (HTML5.toValue f)
        HTML5.input ! HTML5A.type_ "hidden" ! HTML5A.name  (HTML5.toValue dk)
                                            ! HTML5A.value (HTML5.toValue (""::Text))
        HTML5.input ! HTML5A.type_ "hidden" ! HTML5A.name  (HTML5.toValue gk)
                                            ! HTML5A.value (HTML5.toValue gv)
        HTML5.input ! HTML5A.type_ "submit" ! HTML5A.value "subscribe"

defSubAwaitEmail :: Monad m => Address -> m Html
defSubAwaitEmail subAddr = do
  pure . HTML5.docTypeHtml $ do
    HTML5.head $ pure ()
    HTML5.body $ do
      toMarkup . mconcat $
        [ "You should receive an email at "
        , renderAddress subAddr
        , " shortly which will enable you to complete the signup process."
        ]

defOptInEmail :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m
                ,IsElem NewsletterSubConfirmGet (ApiRoot m))
              => Text -> Address -> m (Address -> Mail)
defOptInEmail subject toAddr = do
  l <- genSubConfirmLink toAddr
  let tl = TL.pack $ show l
  let p1 = mconcat $
        [ "We have received a request for subscription of your email address, \""
        , TL.fromStrict (renderAddress toAddr), "\" to  this mailing list. To confirm you wish to be added to this "
        , " mailing list visit:"
        ]
  let p2 = "If you do not wish to be subscribed no action is required."
  let plainBody = mconcat $
        [ p1
        , "\n\n"
        , tl
        , "\n\n"
        , p2
        ]
  let htmlBody  = renderHtml $ do
        HTML5.p $ toMarkup p1
        HTML5.a ! HTML5A.href (toValue tl) $ toMarkup tl
        HTML5.p $ toMarkup p2
  return $ \fromAddr ->
    simpleMailInMemory
      toAddr
      fromAddr
      subject
      plainBody
      htmlBody
      []

defConf :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m
               ,IsElem NewsletterSubConfirmGet (ApiRoot m))
             => Address -> m Html
defConf addr = do
  pure . HTML5.docTypeHtml $ do
    HTML5.head $ pure ()
    HTML5.body $ do
      HTML5.p $ "To complete the subscription process, you click the button below."
      HTML5.form ! HTML5A.method "POST" $ do
        HTML5.input ! HTML5A.type_ "submit"
                    ! HTML5A.value (toValue (printf "Confirm subscription  %s" (renderAddress addr)::String))

defConfed :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m)
            => Address -> m Html
defConfed addr = do
  pure . HTML5.docTypeHtml $ do
    HTML5.head $ pure ()
    HTML5.body $ do
      toMarkup (printf "Subscription for %s confirmed." (renderAddress addr)::String)

defUnsubConf :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m
               ,IsElem NewsletterSubConfirmGet (ApiRoot m))
             => Address -> m Html
defUnsubConf (Address _ e) = do
  pure . HTML5.docTypeHtml $ do
    HTML5.head $ pure ()
    HTML5.body $ do
      HTML5.form ! HTML5A.method "POST" $ do
        HTML5.input ! HTML5A.type_ "submit"
                    ! HTML5A.value (toValue (printf "Unsubscribe %s" e::String))

defUnsubbed :: (HasClientSessionKey k, HasApiRoot m, MonadReader k m, MonadIO m)
            => Address -> m Html
defUnsubbed _ = do
  pure . HTML5.docTypeHtml $ do
    HTML5.head $ pure ()
    HTML5.body $ do
      "Your unsubscription has been processed"