{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}
module Clckwrks.MailingList.Admin.EditMessage where
import Clckwrks (query, update, notFound, seeOtherURL)
import Clckwrks.Admin.Template (template)
import Clckwrks.MailingList.Acid (MessageById(..), UpdateMessage(..))
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 (MonadIO, 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)
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)
editMessage :: MailingListURL -> MessageId -> MailingListM Response
editMessage here msgid =
do mMessage <- query (MessageById msgid)
case mMessage of
Nothing -> notFound $ toResponse $ "Message not found: " ++ show (msgid ^. unMessageId)
(Just message) ->
do action <- showURL here
template "edit message" () $ [hsx|
<%>
<% reform (form action) "em" updateMsg Nothing (messageForm message) %>
</%> |]
where
updateMsg :: Message -> MailingListM Response
updateMsg msg =
do update (UpdateMessage msg)
seeOtherURL here
messageForm :: Message -> MailingListForm Message
messageForm msg =
divHorizontal $
(fieldset $
(,,)
<$> (divControlGroup (label' "From" ++> (divControls $ inputText (msg ^. msgFrom ^. unEmail) `setAttrs` [("size" := "80"), ("class" := "input-xxlarge") :: Attr Text Text])))
<*> (divControlGroup (label' "Subject" ++> (divControls $ inputText (msg ^. msgSubject) `setAttrs` [("size" := "80"), ("class" := "input-xxlarge") :: Attr Text Text])))
<*> (divControlGroup (label' "Body" ++> (divControls $ textarea 80 25 (msg ^. msgBody) `setAttrs` [("class" := "input-xxlarge") :: Attr Text Text])))
<* (divFormActions (inputSubmit' (T.pack "Save")))
) `transformEitherM` toMessage
where
inputSubmit' :: Text -> MailingListForm (Maybe Text)
inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn") :: Attr Text Text]
-- inputCheckboxLabel :: Text -> Bool -> MailingListForm Bool
-- inputCheckboxLabel lbl b = mapView (\xml -> [[hsx| <label class="checkbox"><% xml %><% lbl %></label>|]]) (inputCheckbox b)
label' :: L.Text -> MailingListForm ()
label' str = (labelText str `setAttrs` [("class":="control-label") :: Attr Text Text])
labelCB :: L.Text -> MailingListForm ()
labelCB str = labelText str `setAttrs` [("class":="checkbox") :: Attr Text Text]
-- divInline = mapView (\xml -> [<div class="checkbox inline"><% xml %></div>])
divFormActions = mapView (\xml -> [[hsx|<div class="form-actions"><% xml %></div>|]])
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>|]])
toMessage :: (MonadIO m) => (Text, Text, Text) -> m (Either MailingListFormError Message)
toMessage (from, subj, bdy) =
pure $ Right $ msg & msgFrom .~ (Email from)
& msgSubject .~ subj
& msgBody .~ bdy