NewMessage.hs

{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}
module Clckwrks.MailingList.Admin.NewMessage where

import Clckwrks                    (query, update, notFound, seeOtherURL)
import Clckwrks.Admin.Template     (template)
import Clckwrks.MailingList.Acid   (MessageById(..), CreateMessage(..), 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)

newMessage :: MailingListURL -> MailingListM Response
newMessage here =
  do action <- showURL here
     template "new message" () $
       [hsx| <%>
              <% reform (form action) "nm" createMsg Nothing newMessageForm %>
             </%>
           |]
  where
    createMsg :: Maybe Text -> MailingListM Response
    createMsg _ =
      do msgid <- update CreateMessage
         seeOtherURL (MailingListAdmin (EditMessage msgid))

newMessageForm :: MailingListForm (Maybe Text)
newMessageForm =
      divHorizontal $
      (fieldset $
         divFormActions (inputSubmit' (T.pack "Create New Message"))
      ) -- `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
-}