{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}
module Clckwrks.MailingList.Admin.SendMessage where
import Clckwrks (query, update)
import Clckwrks.Admin.Template (template)
import Clckwrks.MailingList.Acid (MessageById(..))
import Clckwrks.MailingList.Monad (MailingListConfig(mailingListClckURL), MailingListM, MailingListForm, MailingListFormError(InvalidEmail, MissingSubject, MissingLink, SendmailNotFound))
import Clckwrks.MailingList.Types (Email(..), Message(..), MessageId, msgId, msgFrom, msgSubject, msgBody, unEmail, unMessageId)
import Clckwrks.MailingList.URL
import Control.Monad.Trans (liftIO)
import Control.Lens ((^.))
import Data.Maybe (fromMaybe, maybe)
import Data.Monoid (mempty)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import Language.Haskell.HSX.QQ (hsx)
import Happstack.Server (Response, seeOther, toResponse, notFound)
import HSP
import System.Directory (doesFileExist)
import Text.Html.Email.Validate (isValidEmail)
import Text.Reform ( CommonFormError(..), Form, FormError(..), Proof(..), (++>)
, (<++), prove, transformEither, transformEitherM, transform, mapView)
import qualified Text.Reform.Generalized as G
import Text.Reform.Happstack (reform)
import Text.Reform.HSP.Text (form, inputEmail, inputText, setAttrs, label, labelText, inputSubmit, errorList, textarea, fieldset)
import Web.Routes (showURL)
sendMessage :: MailingListURL
-> MessageId
-> MailingListM Response
sendMessage here mid =
do template "send message" () $
do mMsg <- query (MessageById mid)
case mMsg of
Nothing ->
do html <- [hsx| <p>Message <% show $ mid ^. unMessageId %> not found.</p> |]
notFound $ html
(Just msg) ->
[hsx| <div>
<h1>Send Message <% show $ mid ^. unMessageId %></h1>
<h2>Preview</h2>
<div>From: <%msg ^. msgFrom ^. unEmail %></div>
<div>Subject: <%msg ^. msgSubject %></div>
<pre><%msg ^. msgBody %></pre>
</div>
|]
{-
do template "send mailing" () $
[hsx| <%>
<h1>Send Mailing</h1>
<% reform (form here) "ep" sendTheMessage Nothing (sendMailingForm) %>
</%> |]
where
updateMailingListSettings :: (Maybe FilePath, Email, Message) -> MailingListM Response
updateMailingListSettings (sendmailPath, email, message) =
do update (SetMailingListSettings sendmailPath (Just email) (Just message))
hereURL <- showURL here
seeOther hereURL (toResponse ())
sendMailingForm :: Maybe Message -> MailingListForm (Maybe FilePath, Email, Message)
sendMailingForm mMessage =
let message = fromMaybe (optInConfirmMsg (fromMaybe (Email mempty) mEmail)) mMessage
in
divHorizontal $
fieldset $
errorList ++>
( (toSettings (message ^. msgId))
<$> errorList ++>
(divControlGroup (label' "sendmail path" ++>
(divControls $ inputText (T.pack $ fromMaybe "" mSendmail)
`setAttrs` [("class" := "input-xxlarge") :: Attr Text Text]
`transformEitherM`
(\p -> if T.null p
then pure (Right Nothing)
else do let fp = T.unpack p
b <- liftIO $ doesFileExist fp
if b
then pure (Right (Just fp))
else pure (Left SendmailNotFound)
))))
<*> errorList ++>
(divControlGroup (label' "From:" ++>
(divControls $ inputEmail (message ^. msgFrom ^. unEmail )
`setAttrs` [("class" := "input-xxlarge") :: Attr Text Text]
`transformEither` validEmail)))
<*> errorList ++>
(divControlGroup (label' "Subject: " ++>
(divControls $ inputText (message ^. msgSubject)
`setAttrs` [("class" := "input-xxlarge") :: Attr Text Text]
`transformEither` subjectRequired)))
<*> errorList ++>
(divControlGroup (label' "Body:" ++>
(divControls $ textarea 80 25 (message ^. msgBody)
`setAttrs` [("class" := "input-xxlarge") :: Attr Text Text]
`transformEither` linkRequired)))
<* (divControlGroup (divControls $ (inputSubmit (T.pack "Update") `setAttrs`[("class" := "btn") :: Attr Text Text])))
)
where
label' :: L.Text -> MailingListForm ()
label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr L.Text L.Text])
divHorizontal = mapView (\xml -> [ [hsx| <div class="form-horizontal"><% xml %></div>|]])
divControlGroup = mapView (\xml -> [ [hsx| <div class="control-group"><% xml %></div> |]])
divControls = mapView (\xml -> [ [hsx| <div class="controls"><% xml %></div> |]])
validEmail :: T.Text -> Either MailingListFormError Email
validEmail email =
if isValidEmail email
then (Right (Email email))
else (Left InvalidEmail)
subjectRequired :: Text -> Either MailingListFormError Text
subjectRequired subj
| T.null subj = Left MissingSubject
| otherwise = Right subj
linkRequired :: T.Text -> Either MailingListFormError Text
linkRequired bdy =
case T.breakOn "$link$" bdy of
(before, after)
| T.null after -> Left MissingLink
| otherwise -> Right bdy
toSettings :: MessageId -> Maybe FilePath -> Email -> Text -> T.Text -> (Maybe FilePath, Email, Message)
toSettings mid sendmailPath email subject bdy =
( sendmailPath
, email
, Message { _msgId = mid
, _msgFrom = email
, _msgSubject = subject
, _msgBody = bdy
})
-}