{-# LANGUAGE FlexibleContexts, QuasiQuotes, RecordWildCards, OverloadedStrings, TypeFamilies #-}
module Clckwrks.MailingList.Page.Subscribe where

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 (sendmail, sendmailCustom, renderMail')
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, inputEmail, inputText, setAttrs, label, inputSubmit, errorList)

subscribePage :: MailingListURL -> MailingListM Response
subscribePage here =
    do mOptInConfirmMsg <- query GetOptInConfirmMessage
       case mOptInConfirmMsg of
          (Just optInConfirmMsg) ->
            template (fromString "Subscribe to Our Mailing List") ()
                 [hsx|
                  <section class="section">
                   <div class="container">
                     <h1 class="title is-1">Subscribe</h1>
                     <p>Enter your email to subscribe to our mailing list. A confirmation link will be sent to your email address. You must click on the link to complete your subscription. You can unsubscribe at anytime.</p>
                     <% reform (form here) "sub" (subscribe optInConfirmMsg) Nothing emailForm %>
                   </div>
                 </section>
                 |]
          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 <- withAbs $ showURLParams ConfirmOptIn [("id", Just $ Text.pack $ show $ sub ^. subId ^. unSubscriberId), ("uuid", Just (UUID.toText uuid))]
                 mail <- liftIO $ renderMail' (sendStringTemplateEmail [("link", url)] message email)
                 liftIO $ Char8.putStrLn mail
                 mSendmailPath <- query GetSendmailPath
                 liftIO $ case mSendmailPath of
                           Nothing -> sendmail mail
                           (Just path) -> sendmailCustom path ["-t"] mail
                 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>
                  |]

type MailingListFormT m = ClckFormT MailingListFormError (MailingListT m)
emailForm :: (Functor m, MonadIO m, Happstack m) => MailingListFormT m Email
emailForm =
  (formGrp (errorList ++> (label ("Email:" :: Text) `setAttrs` [("class" := "label"):: Attr Text Text]) ++>
            (p $ (inputEmail mempty `setAttrs` [("class" := "input"):: Attr Text Text]) `transformEither` email))) <*
  (formGrp (inputSubmit (pack "subscribe") `setAttrs` [("class" := "button btn btn-default"):: Attr Text Text]))

  where
    p frm = mapView (\xml -> [hsx| [<p class="control"><% xml %></p>] |]) frm
    formGrp frm = mapView (\xml -> [hsx| [<div class="form-group control"><% xml %></div>] |]) frm
    email addr =
      if isValidEmail addr
       then Right $ Email addr
       else Left InvalidEmail