{-# LANGUAGE FlexibleContexts, QuasiQuotes, RecordWildCards, OverloadedStrings, TypeFamilies #-}
module Clckwrks.MailingList.Page.ConfirmOptIn where
import Control.Applicative (optional)
import Control.Lens ((^.))
import Control.Lens.At (at)
import Control.Monad.Reader (ReaderT, ask)
import Control.Monad.State (get)
import Clckwrks
import Clckwrks.MailingList.Acid
import Clckwrks.MailingList.Monad
import Clckwrks.MailingList.Page.Template (template)
import Clckwrks.MailingList.Types
import Clckwrks.MailingList.URL
import qualified Data.ByteString.Lazy.Char8 as Char8
import Data.String (fromString)
import Data.Monoid (mempty)
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Data.Time (UTCTime, getCurrentTime)
import Data.Text (Text, pack)
import qualified Data.Text as Text
import qualified Data.UUID as UUID
import Data.UUID.V4 (nextRandom)
import Network.Mail.Mime (renderSendMail, renderMail')
import Happstack.Server (look)
import HSP
import Language.Haskell.HSX.QQ (hsx)
import Text.Html.Email.Validate (isValidEmail)
import Text.Reform ( CommonFormError(..), Form, FormError(..), Proof(..), (++>)
, (<++), prove, transformEither, transform, mapView)
import qualified Text.Reform.Generalized as G
import Text.Reform.Happstack (reform)
import Text.Reform.HSP.Text (form, inputText, setAttrs, label, inputSubmit, errorList)
-- |FIXME: GET requests are not supposed to modify the state
-- |FIXME: when subscription fails but they are already subscribed
confirmOptInPage :: MailingListM Response
confirmOptInPage =
do mId <- optional $ look "id"
mUUID <- optional $ look "uuid"
case (mId, mUUID) of
(Just idText, Just uuidStr) ->
case reads idText of
[(n, [])] ->
case UUID.fromString uuidStr of
(Just uuid) ->
do now <- liftIO $ getCurrentTime
r <- update (VerifyOptIn now (SubscriberId n) uuid)
case r of
SubscriptionConfirmed -> validOptIn
InvalidConfirmation -> invalidOptIn
AlreadySubscribed -> alreadySubscribed
_ -> invalidOptIn
_ -> invalidOptIn
where
validOptIn =
template (fromString "Subscription Confirmed!") ()
[hsx|
<div>
<h1>Subscription Confirmed</h1>
<p>Your subscription has been successfully confirmed.</p>
</div>
|]
invalidOptIn =
template (fromString "Invalid Confirmation") ()
[hsx|
<div>
<h1>Invalid Confirmation</h1>
<p>We were unable to confirm your subscription.</p>
</div>
|]
alreadySubscribed =
template (fromString "Already Subscribed") ()
[hsx|
<div>
<h1>Already Subscribed</h1>
<p>You have already confirmed your subscription.</p>
</div>
|]
{-
do r <- udpate ConfirmOptIn email uuid
->a mOptInConfirmMsg <- query GetOptInConfirmMessage
case mOptInConfirmMsg of
(Just optInConfirmMsg) ->
template (fromString "Subscribe to Our Mailing List") ()
[hsx|
<div>
<% reform (form here) "sub" (subscribe optInConfirmMsg) Nothing emailForm %>
</div>
|]
Nothing ->
template (fromString "Server Configuration Error") ()
[hsx|
<div>
<h1>Server Configuration Error</h1>
<p>Sorry. The server administrator has not yet configuration the mailing list plugin.</p>
</div>
|]
where
subscribe :: Message -> Email -> MailingListM Response
subscribe message email =
do uuid <- liftIO nextRandom
now <- liftIO getCurrentTime
sub <- update (SignupSubscriber email (AwaitingConfirmation uuid) now)
case sub ^. subStatus of
(_, Subscribed):_ ->
template "You are already subscribed!" ()
[hsx|
<p>You are already subscribed to this mailing list.</p>
|]
(_, AwaitingConfirmation uuid):_ ->
do url <- showURLParams ConfirmOptIn [("email", Just $ email^.unEmail), ("uuid", Just (UUID.toText uuid))]
liftIO $ Char8.putStrLn =<< renderMail' (sendStringTemplateEmail [("link", url)] message email)
template "Subscription Confirmation Sent!" ()
[hsx|
<p>A confirmation email has been sent to your email address. You must click on the link in the email to confirm your subscription.</p>
|]
emailForm :: MailingListForm Email
emailForm =
(formGrp (errorList ++> label ("Email:" :: Text) ++> (inputText mempty `transformEither` email))) <*
(formGrp (inputSubmit (pack "subscribe") `setAttrs` [("class" := "btn btn-default"):: Attr Text Text]))
where
formGrp frm = mapView (\xml -> [hsx| [<div class="form-group"><% xml %></div>] |]) frm
-- inputEmail :: (Monad m, FormError error, XMLGenerator x, StringType x ~ Text, EmbedAsAttr x (Attr Text FormId), EmbedAsAttr x (Attr Text text)) =>
-- (input -> Either error text)
-- -> text
-- -> Form m input error [XMLGenT x (XMLType x)] () text
inputEmail getInput initialValue = G.input getInput inputField initialValue
where
inputField i a = [hsx| [<input type="email" class="form-control" id=i name=i value=a />] |]
email addr =
if isValidEmail addr
then Right $ Email addr
else Left InvalidEmail
-}