clckwrks-plugin-mailinglist (empty) → 0.3.0.2
raw patch · 20 files changed
+1839/−0 lines, 20 filesdep +HStringTemplatedep +acid-statedep +attoparsecsetup-changed
Dependencies added: HStringTemplate, acid-state, attoparsec, base, bytestring, clckwrks, containers, directory, filepath, happstack-authenticate, happstack-hsp, happstack-server, hsp, hsx2hs, html-email-validate, ixset, lens, mime-mail, mtl, network-uri, reform, reform-happstack, reform-hsp, safecopy, text, time, uuid, uuid-orphans, web-plugins, web-routes, web-routes-th
Files
- Clckwrks/MailingList/Acid.hs +257/−0
- Clckwrks/MailingList/Admin/EditMessage.hs +76/−0
- Clckwrks/MailingList/Admin/MailingListSettings.hs +118/−0
- Clckwrks/MailingList/Admin/NewMessage.hs +71/−0
- Clckwrks/MailingList/Admin/SendMessage.hs +134/−0
- Clckwrks/MailingList/Admin/ViewMessages.hs +57/−0
- Clckwrks/MailingList/Admin/ViewSubscribers.hs +54/−0
- Clckwrks/MailingList/Monad.hs +112/−0
- Clckwrks/MailingList/Page/ConfirmOptIn.hs +141/−0
- Clckwrks/MailingList/Page/Subscribe.hs +96/−0
- Clckwrks/MailingList/Page/Template.hs +27/−0
- Clckwrks/MailingList/Plugin.hs +103/−0
- Clckwrks/MailingList/PreProcess.hs +85/−0
- Clckwrks/MailingList/Route.hs +53/−0
- Clckwrks/MailingList/Types.hs +99/−0
- Clckwrks/MailingList/URL.hs +26/−0
- LICENSE +30/−0
- Setup.hs +13/−0
- clckwrks-plugin-mailinglist.cabal +72/−0
- data/style.css +215/−0
+ Clckwrks/MailingList/Acid.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, TemplateHaskell, TypeFamilies, OverloadedStrings #-}+module Clckwrks.MailingList.Acid where++import Control.Lens ((^.), (.=), (?=), (^?), (&), (.~), view, set, over)+import Control.Lens.At (at)+import Control.Applicative ((<$>))+import Control.Lens.At (at)+import Control.Lens.TH (makeLenses)+import Control.Lens.Prism (_Just)+import Control.Monad.Reader (ask)+import Control.Monad.State (get, modify, put)+import Data.Acid (Query, Update, makeAcidic)+import Data.Data (Data, Typeable)+import Data.IxSet (IxSet, Proxy(..), (@=), (@+), getOne, empty, toAscList, toList, fromList, updateIx)+import qualified Data.IxSet as IxSet+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid ((<>))+import Data.Ratio ((%))+import Data.SafeCopy (base, deriveSafeCopy, extension, Migrate(..))+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time (UTCTime(..))+import Data.UUID (UUID)+import Clckwrks.MailingList.Types (Email(..), Message(..), msgId, MessageId(..), Subscriber(..), subId, subStatus, SubscriptionStatus(..), SubscriberId(..), incSubscriberId, msgSubject, msgId)+import System.FilePath (FilePath)++data MailingListState_0 = MailingListState_0+ { _subscribers_0 :: IxSet Subscriber+ , _nextSubscriberId_0 :: SubscriberId+ , _messages_0 :: Map MessageId Message+ , _nextMessageId_0 :: MessageId+ , _contactAddr_0 :: Maybe Email+ , _optInConfirm_0 :: Maybe MessageId+ , _sendmailPath_0 :: Maybe FilePath+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''MailingListState_0++data MailingListState = MailingListState+ { _subscribers :: IxSet Subscriber+ , _nextSubscriberId :: SubscriberId+ , _messages :: Map MessageId Message+ , _mailLog :: Set (MessageId, SubscriberId, UTCTime)+ , _nextMessageId :: MessageId+ , _contactAddr :: Maybe Email+ , _optInConfirm :: Maybe MessageId+ , _sendmailPath :: Maybe FilePath+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 1 'extension ''MailingListState+makeLenses ''MailingListState++instance Migrate MailingListState where+ type MigrateFrom MailingListState = MailingListState_0+ migrate (MailingListState_0 s ns m nm ca oic sp) = MailingListState s ns m Set.empty nm ca oic sp++optInConfirmMsgId :: MessageId+optInConfirmMsgId = MessageId 1++optInConfirmMsg :: Email -> Message+optInConfirmMsg from =+ Message { _msgId = MessageId 1+ , _msgSubject = "Please Confirm Your Mailing List Subscription"+ , _msgFrom = from+ , _msgBody = "Hello,\n\n\+ \\+ \To complete your subscription to our mailing list you must click on the following link:\n\n" <> "$link$" <>+ "\n\nIf you did not issue the request to join this list then you can just ignore this message and you will remain unsubscribed."+ }++initialMailingListState :: MailingListState+initialMailingListState = MailingListState+ { _subscribers = IxSet.empty+ , _nextSubscriberId = SubscriberId 1+ , _messages = Map.empty+ , _mailLog = Set.empty+ , _nextMessageId = MessageId 2+ , _contactAddr = Nothing+ , _optInConfirm = Nothing+ , _sendmailPath = Nothing+-- , _sendQueue = [(SubscriberId, MessageId)]+-- , _mailLog = Set (SubscriberId, MessageId, UTCTime)+ }++-- | FIXME: behavior if email already exists+addSubscriber :: Email -> SubscriptionStatus -> UTCTime -> Update MailingListState Subscriber+addSubscriber email subscriptionStatus now =+ do ms@MailingListState{..} <- get+ case getOne $ (ms ^. subscribers) @= email of+ Nothing -> do+ let subscriber = Subscriber { _subId = _nextSubscriberId+ , _subEmail = email+ , _subStatus = [(now, subscriptionStatus)]+ }+ put $ ms { _subscribers = IxSet.insert subscriber _subscribers+ , _nextSubscriberId = incSubscriberId _nextSubscriberId+ }+ pure subscriber+ (Just subscriber) ->+ pure subscriber++askSubscribers :: Query MailingListState (IxSet Subscriber)+askSubscribers =+ do ms <- ask+ pure $ ms ^. subscribers+{-+askActiveSubscribers :: Query MailingListState (IxSet Subscriber)+askActiveSubscribers =+ do ms <- ask+ case (ms ^. subscribers) @= Subscribed of+ subs -> pure $ filter (\sub -> head (sub ^. subStatus) == Subscribed) IxSet.toList+-}+signupSubscriber :: Email -> SubscriptionStatus -> UTCTime -> Update MailingListState Subscriber+signupSubscriber email subscriptionStatus now =+ do ms@MailingListState{..} <- get+ case getOne $ (ms ^. subscribers) @= email of+ -- email not already in the system+ Nothing -> do+ let subscriber = Subscriber { _subId = _nextSubscriberId+ , _subEmail = email+ , _subStatus = [(now, subscriptionStatus)]+ }+ put $ ms { _subscribers = IxSet.insert subscriber _subscribers+ , _nextSubscriberId = incSubscriberId _nextSubscriberId+ }+ pure subscriber+ (Just subscriber) ->+ case subscriber ^. subStatus of+ -- not sure how this would happen+ [] -> do+ let subscriber' = set subStatus [(now, subscriptionStatus)] subscriber+ put $ ms { _subscribers = IxSet.updateIx (subscriber' ^. subId) subscriber' _subscribers }+ pure subscriber'+ statuses@(currentStatus:previousStatuses) ->+ case currentStatus of+ (_, Subscribed) -> pure subscriber+ (_, AwaitingConfirmation{}) -> pure subscriber+ _ -> do+ let subscriber' = set subStatus ((now, subscriptionStatus):statuses) subscriber+ put $ ms { _subscribers = IxSet.updateIx (subscriber' ^. subId) subscriber' _subscribers }+ pure subscriber'++data VerificationResult+ = SubscriptionConfirmed+ | AlreadySubscribed+ | InvalidConfirmation+deriveSafeCopy 0 'base ''VerificationResult++verifyOptIn :: UTCTime -> SubscriberId -> UUID -> Update MailingListState VerificationResult+verifyOptIn now sid uuid =+ do ms@MailingListState{..} <- get+ case getOne $ (ms ^. subscribers) @= sid of+ Nothing -> pure InvalidConfirmation+ (Just subscriber) ->+ case subscriber ^. subStatus of+ ((_,AwaitingConfirmation uuid'):_)+ | uuid == uuid' ->+ do let subscriber' = subscriber { _subStatus = (now, Subscribed) : (_subStatus subscriber) }+ put $ ms { _subscribers = IxSet.updateIx sid subscriber' _subscribers }+ pure SubscriptionConfirmed+ | otherwise -> pure InvalidConfirmation+ ((_,Subscribed):_) -> pure AlreadySubscribed+ _ -> pure InvalidConfirmation++changeSubscriptionStatus :: SubscriberId -> SubscriptionStatus -> UTCTime -> Update MailingListState (Maybe Subscriber)+changeSubscriptionStatus subscriberId newStatus now =+ do ms@MailingListState{..} <- get+ case getOne $ _subscribers @= subscriberId of+ Nothing -> pure Nothing+ (Just subscriber) ->+ do let subscriber' = subscriber { _subStatus = (now, newStatus) : (_subStatus subscriber) }+ put $ ms { _subscribers = IxSet.updateIx subscriberId subscriber' _subscribers }+ pure $ Just subscriber'++getOptInConfirmMessage :: Query MailingListState (Maybe Message)+getOptInConfirmMessage =+ do mmessageId <- view optInConfirm+ case mmessageId of+ Nothing -> pure Nothing+ (Just messageId) ->+ view (messages . at messageId)++getMailingListSettings :: Query MailingListState (Maybe FilePath, Maybe Email, Maybe Message)+getMailingListSettings =+ do mSendmail <- view sendmailPath+ mEmail <- view contactAddr+ mId <- view optInConfirm+ case mId of+ Nothing -> pure (mSendmail, mEmail, Nothing)+ (Just mid) ->+ do mMessage <- view (messages . at mid)+ pure (mSendmail, mEmail, mMessage)++getSendmailPath :: Query MailingListState (Maybe FilePath)+getSendmailPath = view sendmailPath++setMailingListSettings :: Maybe FilePath+ -> Maybe Email+ -> Maybe Message+ -> Update MailingListState ()+setMailingListSettings mSendmail mEmail mMessage =+ do sendmailPath .= mSendmail+ contactAddr .= mEmail+ case mMessage of+ Nothing -> do+ optInConfirm .= Nothing+ (Just message) -> do+ optInConfirm .= over _Just (^. msgId) mMessage+ messages . at (message ^. msgId) ?= message++addMailLogEntry :: (MessageId, SubscriberId, UTCTime) -> Update MailingListState ()+addMailLogEntry entry =+ do mls@MailingListState {..} <- get+ put $ mls { _mailLog = Set.insert entry _mailLog }++askMessageSubjects :: Query MailingListState [(MessageId, Text)]+askMessageSubjects =+ do mls <- ask+ pure $ map (\(i, m) -> (i, m ^. msgSubject)) (Map.toList $ mls ^. messages)++messageById :: MessageId -> Query MailingListState (Maybe Message)+messageById msgid =+ view (messages . at msgid)++updateMessage :: Message -> Update MailingListState ()+updateMessage msg =+ messages . at (msg ^. msgId) .= Just msg++createMessage :: Update MailingListState MessageId+createMessage =+ do mls <- get+ let msgid = mls ^. nextMessageId+ msg = Message msgid (Email mempty) mempty mempty+ put $ mls & (messages . at msgid) .~ Just msg+ & nextMessageId .~ succ msgid+ pure msgid++$(makeAcidic ''MailingListState+ [ 'addSubscriber+ , 'addMailLogEntry+ , 'askSubscribers+-- , 'askActiveSubscriber+ , 'changeSubscriptionStatus+ , 'getOptInConfirmMessage+ , 'signupSubscriber+ , 'verifyOptIn+ , 'getMailingListSettings+ , 'setMailingListSettings+ , 'getSendmailPath+ , 'askMessageSubjects+ , 'messageById+ , 'updateMessage+ , 'createMessage+ ])
+ Clckwrks/MailingList/Admin/EditMessage.hs view
@@ -0,0 +1,76 @@+{-# 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
+ Clckwrks/MailingList/Admin/MailingListSettings.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}+module Clckwrks.MailingList.Admin.MailingListSettings where++import Clckwrks (query, update)+import Clckwrks.Admin.Template (template)+import Clckwrks.MailingList.Acid (GetMailingListSettings(..), SetMailingListSettings(..), optInConfirmMsg)+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)+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)+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)++mailingListSettings :: MailingListURL -> MailingListM Response+mailingListSettings here =+ do (mSendmailPath, mEmail, mMessage) <- query GetMailingListSettings+ template "mailing list settings" () $+ [hsx| <%>+ <h1>Subscribe</h1>+ <p>Edit the mailing list settings</p>+ <p><% show mEmail %></p>+ <p><% show mMessage %></p>+ <% reform (form here) "ep" updateMailingListSettings Nothing (mailingListSettingsForm mSendmailPath mEmail mMessage) %>+ </%> |]+ 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 ())++mailingListSettingsForm :: Maybe FilePath -> Maybe Email -> Maybe Message -> MailingListForm (Maybe FilePath, Email, Message)+mailingListSettingsForm mSendmail mEmail 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+ })+
+ Clckwrks/MailingList/Admin/NewMessage.hs view
@@ -0,0 +1,71 @@+{-# 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+-}
+ Clckwrks/MailingList/Admin/SendMessage.hs view
@@ -0,0 +1,134 @@+{-# 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+ })++-}
+ Clckwrks/MailingList/Admin/ViewMessages.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}+module Clckwrks.MailingList.Admin.ViewMessages where++import Clckwrks (query, update)+import Clckwrks.Admin.Template (template)+import Clckwrks.MailingList.Acid (AskMessageSubjects(..))+import Clckwrks.MailingList.Monad (MailingListConfig(mailingListClckURL), MailingListM)+import Clckwrks.MailingList.Types (MessageId, Subscriber, SubscriberId, subId, unSubscriberId, subEmail, unEmail, subStatus, unMessageId)+import Clckwrks.MailingList.URL+import Control.Monad.Trans (liftIO)+import Control.Lens ((^.))+import Data.Maybe (fromMaybe, maybe)+import Data.Monoid (mempty)+import qualified Data.IxSet as IxSet+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)++viewMessages :: MailingListURL -> MailingListM Response+viewMessages here =+ do msgs <- query AskMessageSubjects+ template "mailing list messages" () $+ [hsx| <%>+ <h1>Messages</h1>+ <table class="table">+ <thead>+ <tr><th>ID</th><th>Subject</th><th>Edit</th><th>Send</th></tr>+ </thead>+ <tbody>+ <% mapM showMessage msgs %>+ </tbody>+ </table>+ </%> |]+ where+ showMessage :: (MessageId, Text) -> MailingListM XML+ showMessage (msgid, subj) = do+ editURL <- showURL (MailingListAdmin $ EditMessage msgid)+ sendURL <- showURL (MailingListAdmin $ SendMessage msgid)+ unXMLGenT $ [hsx|+ <tr>+ <td><% show $ msgid ^. unMessageId %></td>+ <td><% subj %></td>+ <td><a href=editURL>edit</a></td>+ <td><a href=sendURL>send</a></td>+ </tr>+ |]
+ Clckwrks/MailingList/Admin/ViewSubscribers.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE RecordWildCards, OverloadedStrings, QuasiQuotes #-}+module Clckwrks.MailingList.Admin.ViewSubscribers where++import Clckwrks (query, update)+import Clckwrks.Admin.Template (template)+import Clckwrks.MailingList.Acid (AskSubscribers(..))+import Clckwrks.MailingList.Monad (MailingListConfig(mailingListClckURL), MailingListM)+import Clckwrks.MailingList.Types (Subscriber, SubscriberId, subId, unSubscriberId, subEmail, unEmail, subStatus)+import Clckwrks.MailingList.URL+import Control.Monad.Trans (liftIO)+import Control.Lens ((^.))+import Data.Maybe (fromMaybe, maybe)+import Data.Monoid (mempty)+import qualified Data.IxSet as IxSet+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)++viewSubscribers :: MailingListURL -> MailingListM Response+viewSubscribers here =+ do subs <- query AskSubscribers+ template "mailing list subscribers" () $+ [hsx| <%>+ <h1>Subscribers</h1>+ <table class="table">+ <thead>+ <tr><th>ID</th><th>Email</th><th>Status</th></tr>+ </thead>+ <tbody>+ <% mapM showSubscriber (IxSet.toAscList (IxSet.Proxy :: IxSet.Proxy SubscriberId) subs) %>+ </tbody>+ </table>+ </%> |]+ where+ showSubscriber :: Subscriber -> MailingListM XML+ showSubscriber sub=+ unXMLGenT $ [hsx|+ <tr>+ <td><% show $ sub ^. subId ^. unSubscriberId %></td>+ <td><% sub ^. subEmail ^. unEmail %></td>+ <td><% show $ head $ sub ^. subStatus %></td>+ </tr>+ |]
+ Clckwrks/MailingList/Monad.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, TypeFamilies, TypeSynonymInstances, UndecidableInstances, OverloadedStrings #-}+module Clckwrks.MailingList.Monad where++import Clckwrks (Clck, ClckT(..), ClckFormT, ClckState(..), ClckURL(..), mapClckT, withRouteT)+import Clckwrks.Acid+import Clckwrks.IOThread (IOThread(..), startIOThread, killIOThread)+import Clckwrks.MailingList.Acid+import Clckwrks.MailingList.Types+import Clckwrks.MailingList.URL+import Control.Applicative ((<$>))+import Control.Exception (bracket)+import Control.Monad.Reader (ReaderT(..), MonadReader(..))+import Control.Monad.State (get)+import Control.Monad.Trans (MonadIO, lift)+import Clckwrks.Plugin (clckPlugin)+import Data.Acid (AcidState)+import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom)+import Data.Typeable (Typeable)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Happstack.Server+import Happstack.Server.Internal.Monads (FilterFun)+import HSP (Attr((:=)), Attribute(MkAttr), EmbedAsAttr(..), EmbedAsChild(..), IsName(toName), XMLGenT, XML, pAttrVal)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import Text.Reform (CommonFormError, FormError(..))+import Web.Plugins.Core (Plugin(..), getConfig, getPluginsSt, getPluginRouteFn)+import Web.Routes (URL, MonadRoute, showURL)+++data MailingListConfig = MailingListConfig+ { mailingListState :: AcidState MailingListState+ , mailingListClckURL :: ClckURL -> [(T.Text, Maybe T.Text)] -> T.Text+ }+ deriving Typeable++type MailingListT m = ClckT MailingListURL (ReaderT MailingListConfig m)+type MailingListM = ClckT MailingListURL (ReaderT MailingListConfig (ServerPartT IO))++data MailingListFormError+ = MailingListCFE (CommonFormError [Input])+ | InvalidEmail+ | MissingLink+ | MissingSubject+ | SendmailNotFound+ deriving Show++instance FormError MailingListFormError where+ type ErrorInputType MailingListFormError = [Input]+ commonFormError = MailingListCFE++instance (Functor m, Monad m) => EmbedAsChild (MailingListT m) MailingListFormError where+ asChild InvalidEmail = asChild ("This is definitely not a valid email address." :: T.Text)+ asChild e = asChild (show e)++type MailingListForm = ClckFormT MailingListFormError MailingListM++instance (IsName n TL.Text) => EmbedAsAttr MailingListM (Attr n MailingListURL) where+ asAttr (n := u) =+ do url <- showURL u+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict url))++instance (IsName n TL.Text) => EmbedAsAttr MailingListM (Attr n ClckURL) where+ asAttr (n := url) =+ do showFn <- mailingListClckURL <$> ask+ asAttr $ MkAttr (toName n, pAttrVal (TL.fromStrict $ showFn url []))++runMailingListT :: MailingListConfig -> MailingListT m a -> ClckT MailingListURL m a+runMailingListT mc m = mapClckT f m+ where+ f r = runReaderT r mc++runMailingListT'' :: Monad m =>+ (MailingListURL -> [(T.Text, Maybe T.Text)] -> T.Text)+ -> MailingListConfig+ -> MailingListT m a+ -> ClckT url m a+runMailingListT'' showMailingListURL stripeConfig m = ClckT $ withRouteT flattenURL $ unClckT $ runMailingListT stripeConfig $ m+ where+ flattenURL :: ((url' -> [(T.Text, Maybe T.Text)] -> T.Text) -> (MailingListURL -> [(T.Text, Maybe T.Text)] -> T.Text))+ flattenURL _ u p = showMailingListURL u p+++instance (Monad m) => MonadReader MailingListConfig (MailingListT m) where+ ask = ClckT $ ask+ local f (ClckT m) = ClckT $ local f m++instance (Functor m, Monad m) => GetAcidState (MailingListT m) MailingListState where+ getAcidState =+ mailingListState <$> ask++flattenURLClckT :: (url1 -> [(T.Text, Maybe T.Text)] -> T.Text)+ -> ClckT url1 m a+ -> ClckT url2 m a+flattenURLClckT showClckURL m = ClckT $ withRouteT flattenURL $ unClckT m+ where+ flattenURL _ = \u p -> showClckURL u p++clckT2MailingListT :: (Functor m, MonadIO m, Typeable url1) =>+ ClckT url1 m a+ -> MailingListT m a+clckT2MailingListT m =+ do p <- plugins <$> get+ (Just clckShowFn) <- getPluginRouteFn p (pluginName clckPlugin)+ flattenURLClckT clckShowFn $ mapClckT addReaderT m+ where+ addReaderT :: (Monad m) => m (a, ClckState) -> ReaderT MailingListConfig m (a, ClckState)+ addReaderT m =+ do (a, cs) <- lift m+ return (a, cs)
+ Clckwrks/MailingList/Page/ConfirmOptIn.hs view
@@ -0,0 +1,141 @@+{-# 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++-}
+ Clckwrks/MailingList/Page/Subscribe.hs view
@@ -0,0 +1,96 @@+{-# 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+
+ Clckwrks/MailingList/Page/Template.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts, QuasiQuotes, OverloadedStrings #-}+module Clckwrks.MailingList.Page.Template where++import Clckwrks+import Clckwrks.MailingList.Monad+import Clckwrks.MailingList.URL+import Clckwrks.Plugin+import Control.Monad.Reader+import Control.Monad.State+import Data.Text (Text)+import Language.Haskell.HSX.QQ (hsx)+import HSP hiding (escape)+import Happstack.Server.HSP.HTML ()+import Web.Plugins.Core (Plugin(..), getPluginRouteFn, getTheme)++template :: ( EmbedAsChild MailingListM headers+ , EmbedAsChild MailingListM body+ ) =>+ Text+ -> headers+ -> body+ -> MailingListM Response+template ttl hdrs bdy =+ do p <- plugins <$> get+ hdrXml <- fmap (map unClckChild) $ unXMLGenT $ asChild [hsx| <%> <link rel="stylesheet" type="text/css" href=(MailingListData "style.css") /> <% hdrs %></%> |]+ bdyXml <- fmap (map unClckChild) $ unXMLGenT $ asChild bdy+ clckT2MailingListT $ themeTemplate p (ThemeStyleId 0) ttl hdrXml bdyXml
+ Clckwrks/MailingList/Plugin.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE RecordWildCards, FlexibleContexts, OverloadedStrings #-}+module Clckwrks.MailingList.Plugin where++import Clckwrks+import Clckwrks.Plugin+import Clckwrks.MailingList.URL+import Clckwrks.MailingList.Acid+import Clckwrks.MailingList.PreProcess (mailingListCmd)+import Clckwrks.MailingList.Monad+import Clckwrks.MailingList.Route+import Control.Monad.State (get)+import Data.Acid (AcidState)+import Data.Acid.Local+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text.Lazy as TL+import Data.Maybe (fromMaybe)+import System.FilePath ((</>))+import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, getConfig, getPluginRouteFn, getPluginState, initPlugin)++mailingListHandler :: (MailingListURL -> [(Text, Maybe Text)] -> Text)+ -> MailingListConfig+ -> ClckPlugins+ -> [Text]+ -> ClckT ClckURL (ServerPartT IO) Response+mailingListHandler showMailingListURL mailingListConfig plugins paths =+ case parseSegments fromPathSegments paths of+ (Left e) -> notFound $ toResponse (show e)+ (Right u) ->+ ClckT $ withRouteT flattenURL $ unClckT $ runMailingListT mailingListConfig $ routeMailingList u+ where+ flattenURL :: ((url' -> [(Text, Maybe Text)] -> Text) -> (MailingListURL -> [(Text, Maybe Text)] -> Text))+ flattenURL _ u p = showMailingListURL u p++navBarCallback :: (MailingListURL -> [(Text, Maybe Text)] -> Text)+ -> ClckT ClckURL IO (String, [NamedLink])+navBarCallback showMailingListURL =+ do let subscribeLink = NamedLink { namedLinkTitle = "Subscribe", namedLinkURL = showMailingListURL Subscribe [] }+ pure ("Mailing List", [subscribeLink])++mailingListInit :: ClckPlugins+ -> IO (Maybe Text)+mailingListInit plugins =+ do (Just mailingListShowFn) <- getPluginRouteFn plugins (pluginName mailingListPlugin)+ (Just clckShowFn) <- getPluginRouteFn plugins (pluginName clckPlugin)+ mTopDir <- clckTopDir <$> getConfig plugins+ let basePath = maybe "_state" (\td -> td </> "_state") mTopDir -- FIXME+ acid <- openLocalStateFrom (basePath </> "mailingList") initialMailingListState+ addCleanup plugins Always (createCheckpointAndClose acid)+ let mailingListConfig = MailingListConfig+ { mailingListState = acid+ , mailingListClckURL = clckShowFn+ }+ addPreProc plugins (\txt-> runMailingListT'' mailingListShowFn mailingListConfig $ mailingListCmd mailingListShowFn txt)+ addNavBarCallback plugins (navBarCallback mailingListShowFn)+ addHandler plugins (pluginName mailingListPlugin) (mailingListHandler mailingListShowFn mailingListConfig)+ return Nothing++addMailingListAdminMenu :: ClckT url IO ()+addMailingListAdminMenu =+ do p <- plugins <$> get+ (Just showMailingListURL) <- getPluginRouteFn p (pluginName mailingListPlugin)+ let editMLSettingsURL = showMailingListURL (MailingListAdmin EditMLSettings) []+-- sendMailingURL = showMailingListURL (MailingListAdmin SendMailing) []+ subscribersURL = showMailingListURL (MailingListAdmin ViewSubscribers) []+ viewMessagesURL = showMailingListURL (MailingListAdmin ViewMessages) []+ newMessageURL = showMailingListURL (MailingListAdmin NewMessage) []+ addAdminMenu ("MailingList",+ [ (Set.fromList [Administrator], "Edit Settings", editMLSettingsURL)+-- , (Set.fromList [Administrator], "Send Mailing", sendMailingURL)+ , (Set.fromList [Administrator], "Subscribers", subscribersURL)+ , (Set.fromList [Administrator], "New Message", newMessageURL)+ , (Set.fromList [Administrator], "View Messages", viewMessagesURL)+ ])+++runMailingListT' :: MonadIO m =>+ ClckPlugins+ -> MailingListT m a+ -> ClckT url m a+runMailingListT' plugins m =+ do mMailingListConfig <- liftIO $ getPluginState plugins (pluginName mailingListPlugin)+ mRouteFn <- liftIO $ getPluginRouteFn plugins (pluginName mailingListPlugin)+ case (mMailingListConfig, mRouteFn) of+ (Just mailingListConfig, Just routeFn) ->+ runMailingListT'' routeFn mailingListConfig m++++mailingListPlugin :: Plugin MailingListURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt+mailingListPlugin = Plugin+ { pluginName = "mailingList"+ , pluginInit = mailingListInit+ , pluginDepends = []+ , pluginToPathInfo = toPathInfo+ , pluginPostHook = addMailingListAdminMenu+ }++plugin :: ClckPlugins -- ^ plugins+ -> Text -- ^ baseURI+ -> IO (Maybe Text)+plugin plugins baseURI =+ initPlugin plugins baseURI mailingListPlugin
+ Clckwrks/MailingList/PreProcess.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -F -pgmFhsx2hs #-}+module Clckwrks.MailingList.PreProcess where++import Control.Monad.Reader (mapReaderT)+import Control.Monad.Trans+import Control.Applicative+import Clckwrks (ClckT, ClckState)+import Clckwrks.MailingList.URL (MailingListURL(..))+import Clckwrks.MailingList.Page.Subscribe (emailForm)+import Clckwrks.MailingList.Monad+import Clckwrks.MailingList.Types (Email)+import Clckwrks.Monad (mapClckT, transform, segments)+import Data.Attoparsec.Text.Lazy (Parser, Result(..), char, choice, decimal, parse, skipMany, space, asciiCI, skipMany)+import Data.Monoid (mempty)+import Data.Text (Text, pack)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as B+import Happstack.Server (Happstack)+import HSP+import HSP.HTML4 (renderAsHTML)+import Text.Reform (viewForm)+import Text.Reform.Happstack (happstackViewForm, happstackView)+import Text.Reform.HSP.Text (form)+import Web.Routes (showURL)++data MailingListCmd+ = SubscribeFormLink+ | SubscribeForm++parseAttr :: Text -> Parser ()+parseAttr name =+ do skipMany space+ asciiCI name+ skipMany space+ char '='+ skipMany space++parseCmd :: Parser MailingListCmd+parseCmd =+ choice [ asciiCI (pack "subscription-form-link") *> pure SubscribeFormLink+ , asciiCI (pack "subscription-form") *> pure SubscribeForm+ ]++mailingListCmd :: (MailingListURL -> [(Text, Maybe Text)] -> Text)+ -> TL.Text+ -> (forall m. (Functor m, MonadIO m, Happstack m) => MailingListT m TL.Text)+mailingListCmd mailingListShowURL txt =+ case parse (segments "mailing-list" parseCmd) txt of+ (Fail _ _ e) -> return (TL.pack e)+ (Done _ segments) ->+ do b <- transform (applyCmd mailingListShowURL) segments+ return $ B.toLazyText b+++-- type MailingListForm = ClckFormT MailingListFormError MailingListM+-- type ClckFormT error m = Form m [Input] error [XMLGenT m XML] ()+-- type MailingListM = ClckT MailingListURL (ReaderT MailingListConfig (ServerPartT IO))+-- type MailingListT m = ClckT MailingListURL (ReaderT MailingListConfig m)+-- type MailingListForm = ClckFormT MailingListFormError MailingListM+applyCmd :: (MailingListURL -> [(Text, Maybe Text)] -> Text)+ -> MailingListCmd+ -> (forall m. (Functor m, MonadIO m, Happstack m)=> MailingListT m Builder)++applyCmd mailingListShowURL SubscribeFormLink =+ do html <- unXMLGenT $ <a href=(mailingListShowURL Subscribe [])>Join our mailing list!</a>+ return $ B.fromString $ concat $ lines $ TL.unpack $ renderAsHTML html++{-+In order for this to work, we need to be able to add CSRF cookies. However, at present the preprocessor framework only allows you to transform the body. It runs in `ClckT ClckURL IO TL.Text` not `ClckT ClckURL (ServerPartT IO) TL.Text`+-}++applyCmd mailingListShowURL SubscribeForm =+ do url <- showURL Subscribe+ view <- happstackViewForm (\hd v -> form url (("formname", "sub"):hd) v) "sub" emailForm+ html <- unXMLGenT $ sequence view+ return $ B.fromString $ concatMap (concat . lines . TL.unpack . renderAsHTML) html+{-+foo =+ do html <- happstackViewForm (form "") "sub" emailForm+ return ()+-}
+ Clckwrks/MailingList/Route.hs view
@@ -0,0 +1,53 @@+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+module Clckwrks.MailingList.Route where++import Control.Applicative ((<$>))+import Control.Monad.Reader (ask)+import Control.Monad.Trans (liftIO)+import Clckwrks (Role(..), requiresRole_)+import Clckwrks.MailingList.Admin.EditMessage (editMessage)+import Clckwrks.MailingList.Admin.MailingListSettings (mailingListSettings)+import Clckwrks.MailingList.Admin.NewMessage (newMessage)+import Clckwrks.MailingList.Admin.SendMessage(sendMessage)+import Clckwrks.MailingList.Admin.ViewMessages (viewMessages)+import Clckwrks.MailingList.Admin.ViewSubscribers (viewSubscribers)+import Clckwrks.MailingList.Monad (MailingListM, MailingListConfig(..))+import Clckwrks.MailingList.URL (MailingListURL(..), MailingListAdminURL(..))+import Clckwrks.MailingList.Page.Subscribe (subscribePage)+import Clckwrks.MailingList.Page.ConfirmOptIn (confirmOptInPage)+import qualified Data.Set as Set+import Happstack.Server (Response, notFound, toResponse, serveFile, guessContentTypeM, mimeTypes)+import Happstack.Server.FileServe.BuildingBlocks (isSafePath)+import Network.URI (unEscapeString)+import System.FilePath ((</>), makeRelative, splitDirectories)++checkAuth :: MailingListURL+ -> MailingListM MailingListURL+checkAuth url =+ do showFn <- mailingListClckURL <$> ask+ let requiresRole = requiresRole_ showFn+ case url of+ MailingListAdmin {} -> requiresRole (Set.singleton Administrator) url+ Subscribe {} -> return url+ ConfirmOptIn {} -> return url++-- | routes for 'AdminURL'+routeMailingListAdmin :: MailingListAdminURL -> MailingListM Response+routeMailingListAdmin url =+ case url of+ EditMLSettings -> mailingListSettings (MailingListAdmin url)+ ViewSubscribers -> viewSubscribers (MailingListAdmin url)+ (SendMessage msgid) -> sendMessage (MailingListAdmin url) msgid+ (EditMessage msgid) -> editMessage (MailingListAdmin url) msgid+ ViewMessages -> viewMessages (MailingListAdmin url)+ NewMessage -> newMessage (MailingListAdmin url)++routeMailingList :: MailingListURL+ -> MailingListM Response+routeMailingList unsecureURL =+ do url <- checkAuth unsecureURL+ case url of+ Subscribe -> subscribePage url+ ConfirmOptIn -> confirmOptInPage+ (MailingListAdmin adminURL) -> routeMailingListAdmin adminURL+
+ Clckwrks/MailingList/Types.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TemplateHaskell #-}+module Clckwrks.MailingList.Types where++import Clckwrks+import Control.Lens ((^.), to)+import Control.Lens.TH (makeLenses)+import Data.Data (Data, Typeable)+import Data.IxSet (Indexable(..), ixSet, ixFun)+import Data.Maybe (maybeToList)+import Data.SafeCopy (SafeCopy, base, deriveSafeCopy)+import Data.Text (Text, unpack)+import Data.Text.Lazy (toStrict)+import Data.Set (Set)+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Data.UUID.Orphans ()+import Network.Mail.Mime (Address(..), Mail(..), simpleMail')+import Text.StringTemplate (newSTMP, render, setManyAttrib)+import Web.Routes (PathInfo(..))++-- | Email+--+-- Given the many email address RFCs, validation schemes, etc, it+-- seems best to keep this type simple so that we do not have to+-- do migration later. This should allows us to get a Unicode string+-- from the user in a form and then use some tool to validate it.+--+-- Normalization is also non-standard. For example, most systems are+-- not case sensitive, but some are. Additionally, in gmail . is ignored+-- in the local part.+newtype Email = Email { _unEmail :: Text }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''Email+makeLenses ''Email++newtype SubscriberId = SubscriberId { _unSubscriberId :: Integer }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''SubscriberId+makeLenses ''SubscriberId++incSubscriberId :: SubscriberId -> SubscriberId+incSubscriberId (SubscriberId i) = SubscriberId (i + 1)++data SubscriptionStatus+ = Subscribed+ | AwaitingConfirmation UUID+ | Bouncing+ | Unsubscribed+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''SubscriptionStatus++data Subscriber = Subscriber+ { _subId :: SubscriberId+ , _subEmail :: Email+ , _subStatus :: [(UTCTime, SubscriptionStatus)] -- sort newest to oldest -- current status is the first element of the list+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''Subscriber+makeLenses ''Subscriber++instance Indexable Subscriber where+ empty = ixSet [ ixFun $ (:[]) . _subId+ , ixFun $ (:[]) . _subEmail+ , ixFun $ map snd . take 1 . _subStatus -- current subscription status+ ]++-- not to be confused with message-id header+newtype MessageId = MessageId { _unMessageId :: Integer }+ deriving (Eq, Ord, Read, Show, Data, Typeable, PathInfo, Enum)+deriveSafeCopy 0 'base ''MessageId+makeLenses ''MessageId++data MessageStatus+ = Draft+ | Sent UTCTime+ | Scheduled UTCTime+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''MessageStatus++data Message = Message+ { _msgId :: MessageId+ , _msgFrom :: Email+ , _msgSubject :: Text+ , _msgBody :: Text+ }+ deriving (Eq, Ord, Read, Show, Data, Typeable)+deriveSafeCopy 0 'base ''Message+makeLenses ''Message++instance Indexable Message where+ empty = ixSet $ [ ixFun $ (:[]) . _msgId+ ]++emailToAddress :: Email -> Address+emailToAddress (Email eml) = Address Nothing eml++sendStringTemplateEmail :: [(String, Text)] -> Message -> Email -> Mail+sendStringTemplateEmail attrs message toEmail =+ simpleMail' (toEmail ^. to emailToAddress ) (message ^. msgFrom ^. to emailToAddress) (message ^. msgSubject) (render $ setManyAttrib attrs $ newSTMP $ message ^. msgBody ^. to unpack)
+ Clckwrks/MailingList/URL.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}+module Clckwrks.MailingList.URL where++import Data.Data (Data, Typeable)+import Web.Routes.TH (derivePathInfo)+import Clckwrks.MailingList.Types (MessageId(..))++data MailingListAdminURL+ = EditMLSettings+ | ViewSubscribers+ | SendMessage MessageId+ | NewMessage+ | EditMessage MessageId+ | ViewMessages+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(derivePathInfo ''MailingListAdminURL)++-- http://www.list-unsubscribe.com/+data MailingListURL+ = Subscribe+ | UnsubscribeLink+ | ConfirmOptIn+ | MailingListAdmin MailingListAdminURL+ | MailingListData String+ deriving (Eq, Ord, Read, Show, Data, Typeable)+$(derivePathInfo ''MailingListURL)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2013, Jeremy Shaw, SeeReason Partners LLC++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jeremy Shaw nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,13 @@+#!/usr/bin/env runghc++module Main where++import Distribution.Simple+import Distribution.Simple.Program++trhsxProgram = simpleProgram "trhsx"++main :: IO ()+main = defaultMainWithHooks simpleUserHooks {+ hookedPrograms = [trhsxProgram]+ }
+ clckwrks-plugin-mailinglist.cabal view
@@ -0,0 +1,72 @@+Name: clckwrks-plugin-mailinglist+Version: 0.3.0.2+Synopsis: mailing list plugin for clckwrks+Homepage: http://www.clckwrks.com/+License: BSD3+License-file: LICENSE+Author: Jeremy Shaw+Maintainer: Jeremy Shaw <jeremy@n-heptane.com>+Copyright: 2012 Jeremy Shaw, SeeReason Partners LLC+Category: Clckwrks+Build-type: Simple+Cabal-version: >=1.6+Data-Files:+ data/style.css++source-repository head+ type: darcs+ location: http://hub.darcs.net/stepcut/clckwrks-plugin-mailinglist++Library++ Exposed-modules:+ Clckwrks.MailingList.Acid+ Clckwrks.MailingList.Admin.MailingListSettings+ Clckwrks.MailingList.Admin.EditMessage+ Clckwrks.MailingList.Admin.NewMessage+ Clckwrks.MailingList.Admin.SendMessage+ Clckwrks.MailingList.Admin.ViewMessages+ Clckwrks.MailingList.Admin.ViewSubscribers+ Clckwrks.MailingList.Monad+ Clckwrks.MailingList.Plugin+ Clckwrks.MailingList.Page.ConfirmOptIn+ Clckwrks.MailingList.Page.Subscribe+ Clckwrks.MailingList.Page.Template+ Clckwrks.MailingList.PreProcess+ Clckwrks.MailingList.Route+ Clckwrks.MailingList.Types+ Clckwrks.MailingList.URL+ Paths_clckwrks_plugin_mailinglist++ Build-depends:+ base < 5,+ acid-state >= 0.11,+ attoparsec >= 0.10 && < 0.14,+ bytestring,+ clckwrks >= 0.24 && < 0.25,+ containers >= 0.4 && < 0.6,+ directory >= 1.1 && < 1.4,+ html-email-validate,+ filepath >= 1.2 && < 1.5,+ happstack-authenticate >= 2.3 && < 2.4,+ happstack-hsp >= 7.2 && < 7.4,+ happstack-server >= 7.3 && < 7.6,+ hsp >= 0.9 && < 0.11,+ hsx2hs,+ HStringTemplate,+ ixset == 1.0.*,+ lens,+ mime-mail,+ mtl >= 2.0 && < 2.3,+ network-uri >= 2.6 && < 2.7,+ reform == 0.2.*,+ reform-happstack == 0.2.*,+ reform-hsp >= 0.2 && < 0.3,+ safecopy >= 0.6,+ text >= 0.11 && < 1.3,+ time >= 1.4 && < 1.9,+ uuid,+ uuid-orphans,+ web-plugins >= 0.1 && < 0.3,+ web-routes == 0.27.*,+ web-routes-th >= 0.21
+ data/style.css view
@@ -0,0 +1,215 @@+#view-bug dt+{+ font-weight: bold;+}++#view-bug dd+{++}++.bugs ol+{+ list-style-type: none;+}++fieldset.bugs+{+ border: 1px solid #aaa;+ margin-left: 3em;+ margin-right: 3em;+ box-shadow: 5px 5px 1px -2px #bbe;+}++.bugs textarea+{+ font-family: monospace;+}++.bugs input[type='text']+{+ font-family: monospace;+}++/* bug summary */+.bug-summary-open+{+}++.bug-summary-closed+{+ text-decoration: line-through+}++/*****************************************************************************+ * meter+ *+ * http://css-tricks.com/css3-progress-bars/+ *+ *****************************************************************************/+++/* bar container */+.meter {+ height: 20px; /* Can be anything */+ position: relative;+ background: #555;+ -moz-border-radius: 25px;+ -webkit-border-radius: 25px;+ border-radius: 25px;+ padding: 10px;+ -webkit-box-shadow: inset 0 -1px 1px rgba(255,255,255,0.3);+ -moz-box-shadow : inset 0 -1px 1px rgba(255,255,255,0.3);+ box-shadow : inset 0 -1px 1px rgba(255,255,255,0.3);+}++/* progress bar */+.meter > span {+ display: block;+ height: 100%;+ -webkit-border-top-right-radius: 8px;+ -webkit-border-bottom-right-radius: 8px;+ -moz-border-radius-topright: 8px;+ -moz-border-radius-bottomright: 8px;+ border-top-right-radius: 8px;+ border-bottom-right-radius: 8px;+ -webkit-border-top-left-radius: 20px;+ -webkit-border-bottom-left-radius: 20px;+ -moz-border-radius-topleft: 20px;+ -moz-border-radius-bottomleft: 20px;+ border-top-left-radius: 20px;+ border-bottom-left-radius: 20px;+ background-color: rgb(43,194,83);+ background-image: -webkit-gradient(+ linear,+ left bottom,+ left top,+ color-stop(0, rgb(43,194,83)),+ color-stop(1, rgb(84,240,84))+ );+ background-image: -webkit-linear-gradient(+ center bottom,+ rgb(43,194,83) 37%,+ rgb(84,240,84) 69%+ );+ background-image: -moz-linear-gradient(+ center bottom,+ rgb(43,194,83) 37%,+ rgb(84,240,84) 69%+ );+ background-image: -ms-linear-gradient(+ center bottom,+ rgb(43,194,83) 37%,+ rgb(84,240,84) 69%+ );+ background-image: -o-linear-gradient(+ center bottom,+ rgb(43,194,83) 37%,+ rgb(84,240,84) 69%+ );+ -webkit-box-shadow:+ inset 0 2px 9px rgba(255,255,255,0.3),+ inset 0 -2px 6px rgba(0,0,0,0.4);+ -moz-box-shadow:+ inset 0 2px 9px rgba(255,255,255,0.3),+ inset 0 -2px 6px rgba(0,0,0,0.4);+ position: relative;+ overflow: hidden;+}+++/* colors */+.orange > span {+ background-color: #f1a165;+ background-image: -webkit-gradient(linear,left top,left bottom,color-stop(0, #f1a165),color-stop(1, #f36d0a));+ background-image: -webkit-linear-gradient(top, #f1a165, #f36d0a);+ background-image: -moz-linear-gradient(top, #f1a165, #f36d0a);+ background-image: -ms-linear-gradient(top, #f1a165, #f36d0a);+ background-image: -o-linear-gradient(top, #f1a165, #f36d0a);+}++.red > span {+ background-color: #f0a3a3;+ background-image: -webkit-gradient(linear,left top,left bottom,color-stop(0, #f0a3a3),color-stop(1, #f42323));+ background-image: -webkit-linear-gradient(top, #f0a3a3, #f42323);+ background-image: -moz-linear-gradient(top, #f0a3a3, #f42323);+ background-image: -ms-linear-gradient(top, #f0a3a3, #f42323);+ background-image: -o-linear-gradient(top, #f0a3a3, #f42323);+}++/* candy stripe */+.meter > span:after {+ content: "";+ position: absolute;+ top: 0; left: 0; bottom: 0; right: 0;+ background-image:+ -webkit-gradient(linear, 0 0, 100% 100%,+ color-stop(.25, rgba(255, 255, 255, .2)),+ color-stop(.25, transparent), color-stop(.5, transparent),+ color-stop(.5, rgba(255, 255, 255, .2)),+ color-stop(.75, rgba(255, 255, 255, .2)),+ color-stop(.75, transparent), to(transparent)+ );+ background-image:+ -webkit-linear-gradient(+ -45deg,+ rgba(255, 255, 255, .2) 25%,+ transparent 25%,+ transparent 50%,+ rgba(255, 255, 255, .2) 50%,+ rgba(255, 255, 255, .2) 75%,+ transparent 75%,+ transparent+ );+ background-image:+ -moz-linear-gradient(+ -45deg,+ rgba(255, 255, 255, .2) 25%,+ transparent 25%,+ transparent 50%,+ rgba(255, 255, 255, .2) 50%,+ rgba(255, 255, 255, .2) 75%,+ transparent 75%,+ transparent+ );+ background-image:+ -ms-linear-gradient(+ -45deg,+ rgba(255, 255, 255, .2) 25%,+ transparent 25%,+ transparent 50%,+ rgba(255, 255, 255, .2) 50%,+ rgba(255, 255, 255, .2) 75%,+ transparent 75%,+ transparent+ );+ background-image:+ -o-linear-gradient(+ -45deg,+ rgba(255, 255, 255, .2) 25%,+ transparent 25%,+ transparent 50%,+ rgba(255, 255, 255, .2) 50%,+ rgba(255, 255, 255, .2) 75%,+ transparent 75%,+ transparent+ );+ z-index: 1;+ -webkit-background-size: 50px 50px;+ -moz-background-size: 50px 50px;+ background-size: 50px 50px;+ -webkit-animation: move 2s linear infinite;+ -webkit-border-top-right-radius: 8px;+ -webkit-border-bottom-right-radius: 8px;+ -moz-border-radius-topright: 8px;+ -moz-border-radius-bottomright: 8px;+ border-top-right-radius: 8px;+ border-bottom-right-radius: 8px;+ -webkit-border-top-left-radius: 20px;+ -webkit-border-bottom-left-radius: 20px;+ -moz-border-radius-topleft: 20px;+ -moz-border-radius-bottomleft: 20px;+ border-top-left-radius: 20px;+ border-bottom-left-radius: 20px;+ overflow: hidden;+}