Skip to content

Instantly share code, notes, and snippets.

@hasufell

hasufell/mail.patch

Last active November 28, 2015 16:12
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save hasufell/93b3edb09c2f1c4b3d52 to your computer and use it in GitHub Desktop.
Save hasufell/93b3edb09c2f1c4b3d52 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
mail.patch
patch 9d63ed153bf8d64f4989b476eb1b3765e654ded3
Author: Julian Ospald <hasufell@hasufell.de>
Date: Sat Nov 28 16:49:37 CET 2015
* Don't send notification mail to the commenter
patch 9332570d1337856184ff794ed5d747316fce966c
Author: Julian Ospald <hasufell@hasufell.de>
Date: Sat Nov 28 16:08:18 CET 2015
* Adjust mail notification subscription defaults
When creating a new issue or making a comment, you are
automatically subscribed.
patch 466b681be6d8e4d7efd2c04e11588da194bf4f59
Author: Julian Ospald <hasufell@hasufell.de>
Date: Sat Nov 28 15:19:46 CET 2015
* Add more issue changes to the mail notification body
patch 1503ae914c39c3457360ebe7c37e0faa778d6883
Author: Julian Ospald <hasufell@hasufell.de>
Date: Sat Nov 28 00:01:17 CET 2015
* Don't hard-fail on missing subscribers attribute in CouchDB
This makes explicit CouchDB schema conversion obsolete.
patch d0e3b067fa854453fc18c3c894dfe5500503b592
Author: Julian Ospald <hasufell@hasufell.de>
Date: Fri Nov 27 20:50:43 CET 2015
* Fix "From" sender name in sendCommentChangeMail
patch 89c00d8674cb027b6cf136d2419fd03c4c17fde0
Author: Julian Ospald <hasufell@hasufell.de>
Date: Fri Nov 27 15:09:56 CET 2015
* Add simple mail notification system
This also refactors UserHandlers.hs to use the
dedicated Mail.hs module.
Notifications are currently only implemented for the
issue tracker comment section. The mails are sent
in the background.
This changes the CouchDB database layout of the issues!
It adds a
"subscribers":[]
field.
diff -rN -u old-darcsden-mail-notify/darcsden.cabal new-darcsden-mail-notify/darcsden.cabal
--- old-darcsden-mail-notify/darcsden.cabal 2015-11-28 17:12:28.616399280 +0100
+++ new-darcsden-mail-notify/darcsden.cabal 2015-11-28 17:12:28.617399280 +0100
@@ -128,6 +128,7 @@
DarcsDen.Backend.Transient
DarcsDen.Darcs
DarcsDen.Handlers
+ DarcsDen.Mail
DarcsDen.Settings
DarcsDen.Settings.Production
DarcsDen.Settings.Local
diff -rN -u old-darcsden-mail-notify/src/DarcsDen/Handlers/RepoHandlers.hs new-darcsden-mail-notify/src/DarcsDen/Handlers/RepoHandlers.hs
--- old-darcsden-mail-notify/src/DarcsDen/Handlers/RepoHandlers.hs 2015-11-28 17:12:28.616399280 +0100
+++ new-darcsden-mail-notify/src/DarcsDen/Handlers/RepoHandlers.hs 2015-11-28 17:12:28.617399280 +0100
@@ -2,6 +2,7 @@
module DarcsDen.Handlers.RepoHandlers where
import Control.Arrow ((&&&))
+import Control.Concurrent(forkIO)
import Control.Lens (view, set, over)
import Control.Monad (when)
import Control.Monad.Trans
@@ -42,6 +43,7 @@
import DarcsDen.Handlers.RepoHandlerUtils.Browse
import DarcsDen.Handlers.RepoHandlerUtils.Changes
import DarcsDen.Handlers.RepoHandlerUtils.Forks
+import DarcsDen.Mail
import DarcsDen.MimeMapSettings
import DarcsDen.Pages.RepoPages
import DarcsDen.Settings
@@ -711,6 +713,43 @@
issues <- mapM andFind as
return (nubBy ((==) `on` issueRef) (concat issues))
+getRepoSubscribeR :: (?settings :: Settings, BTIO bt, BP bp)
+ => Bool -- ^ subscribe if True, else unsubscribe
+ -> User bp
+ -> Repository bp
+ -> Session
+ -> Snap ()
+getRepoSubscribeR dosub _ r s = validate
+ [ numeric "number"
+ ]
+ (\(OK is) -> do
+ let (str, modifySub, subCheck) =
+ if dosub
+ then ("subscribe", addSub, isSubbed)
+ else ("unsubscribe", rmSub, isUnSubbed)
+ mi <- getIssue (repoRef r) (read $ is ! "number")
+ case mi of
+ Just i ->
+ case sUser s of
+ Just un -> do
+ mni <- updateIssue $ modifySub un i
+ case mni of
+ Nothing -> do
+ warn "issue could not be updated" s
+ redirectTo (issueURL r i)
+ Just ni -> do
+ if subCheck un i
+ then success ("Already " ++ str ++ "d!") s
+ else success ("Successfully " ++ str ++ "d!") s
+ redirectTo (issueURL r ni)
+ Nothing -> do
+ warn ("Must be logged in to " ++ str ++ "!") s
+ redirectTo (issueURL r i)
+ Nothing -> notFoundPage "Issue not found")
+ (\(Invalid f) -> do
+ notify Warning s f
+ redirectTo (repoURL r))
+
getRepoIssueR :: (?settings :: Settings, BTIO bt, BP bp) => User bp -> Repository bp -> Session -> Snap ()
getRepoIssueR u r s = validate
[ numeric "number"
@@ -753,7 +792,7 @@
now <- liftIO getCurrentTime
i <- addIssue $
freshIssueData
- (view rIssueCount r + 1) summary un description
+ (view rIssueCount r + 1) summary un [un] description
(map strip $ wordsBy (== ',') tags) mbn now now
False (repoRef r)
@@ -797,7 +836,6 @@
"and close" -> True
"and reopen" -> False
_ -> view iIsClosed i
-
issueChanged = or
[ view iSummary i /= summary
, view iDescription i /= description
@@ -834,10 +872,11 @@
else do
now <- liftIO getCurrentTime
- addComment $ freshCommentData c changes un now now (issueRef i)
+ com <- addComment $ freshCommentData c changes un now now (issueRef i)
mni <- updateIssue $
- (set iSummary summary .
+ (addSub un .
+ set iSummary summary .
set iDescription description .
set iBundle mbn .
set iTags ts .
@@ -854,6 +893,11 @@
if not (null c)
then success "comment added" s
else success "issue updated" s
+
+ -- don't block the main thread, these could be a lot of
+ -- mails
+ _ <- liftIO $ forkIO $ sendCommentChangeMail un r ni com
+
case issueBeingClosed of
False -> redirectTo (issueURL r ni)
True -> redirectTo (repoURL r ++ "/issues") )
diff -rN -u old-darcsden-mail-notify/src/DarcsDen/Handlers/UserHandlers.hs new-darcsden-mail-notify/src/DarcsDen/Handlers/UserHandlers.hs
--- old-darcsden-mail-notify/src/DarcsDen/Handlers/UserHandlers.hs 2015-11-28 17:12:28.616399280 +0100
+++ new-darcsden-mail-notify/src/DarcsDen/Handlers/UserHandlers.hs 2015-11-28 17:12:28.617399280 +0100
@@ -11,16 +11,14 @@
import Data.Map ((!))
import Data.Maybe (fromJust, isJust)
import Data.List (intercalate, nub, nubBy)
-import Data.Text (pack)
-import qualified Data.Text.Lazy as DTL
import System.Random (randomRIO)
import Snap.Core
import Network.HTTP.Conduit (queryString)
-import Network.Mail.Mime(simpleMail, Address(..), renderSendMail)
import Text.JSON (encode)
import DarcsDen.Backend.Permanent ( BP )
import DarcsDen.Backend.Transient ( BT, BTIO )
+import DarcsDen.Mail
import DarcsDen.Settings
import DarcsDen.State.FileSystem (isSane)
import DarcsDen.State.ForgotPassword
@@ -416,15 +414,7 @@
(\(OK r) -> do
Just u <- getUser (r ! "username")
str <- createFpForUser u
- let v = baseUrl ++ "recovery?fpid=" ++ str
- liftIO $ simpleMail
- (Address (Just . pack $ view uName u) (pack $ view uEmail u))
- (Address (Just . pack $ sendName) (pack $ sendEmail))
- (pack $ "Reset Password")
- DTL.empty
- (DTL.pack $ "<a href="++v++">reset password</a>")
- []
- >>= renderSendMail
+ sendPwResetMail str u
success "Mail sent to user's email account." s
redirectTo baseUrl)
(\(Invalid f) -> notify Warning s f >> redirectTo (baseUrl ++ "forgotpassword"))
diff -rN -u old-darcsden-mail-notify/src/DarcsDen/Handlers.hs new-darcsden-mail-notify/src/DarcsDen/Handlers.hs
--- old-darcsden-mail-notify/src/DarcsDen/Handlers.hs 2015-11-28 17:12:28.616399280 +0100
+++ new-darcsden-mail-notify/src/DarcsDen/Handlers.hs 2015-11-28 17:12:28.617399280 +0100
@@ -137,6 +137,8 @@
,(":user/:repo/issues/tag/:tag" , getRepoIssuesTagR)
,(":user/:repo/issue/:number" , getRepoIssueR)
,(":user/:repo/issue/:number/comment" , getRepoCommentR)
+ ,(":user/:repo/issue/:number/subscribe" , getRepoSubscribeR True)
+ ,(":user/:repo/issue/:number/unsubscribe" , getRepoSubscribeR False)
,(":user/:repo/new-issue" , \u r s' -> method GET (getNewIssueR u r s') <|> method POST (postNewIssueR u r s'))
]
)
diff -rN -u old-darcsden-mail-notify/src/DarcsDen/Mail.hs new-darcsden-mail-notify/src/DarcsDen/Mail.hs
--- old-darcsden-mail-notify/src/DarcsDen/Mail.hs 1970-01-01 01:00:00.000000000 +0100
+++ new-darcsden-mail-notify/src/DarcsDen/Mail.hs 2015-11-28 17:12:28.617399280 +0100
@@ -0,0 +1,106 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, CPP #-}
+
+module DarcsDen.Mail where
+
+import Control.Lens (view)
+import Control.Monad.Trans
+import DarcsDen.Backend.Permanent ( BP )
+import DarcsDen.Backend.Transient ( BTIO )
+import DarcsDen.Settings
+import DarcsDen.State.Comment
+import DarcsDen.State.Issue
+import DarcsDen.State.Repo
+import DarcsDen.State.User
+import DarcsDen.Util(deleteMaybe)
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Text (pack)
+import qualified Data.Text.Lazy as DTL
+import Network.Mail.Mime(simpleMail, Address(..), renderSendMail)
+import Text.Printf
+
+
+-- |Sends a mail for a comment change (on the issue tracker)
+-- with the given context.
+sendCommentChangeMail :: (?settings :: Settings, BP bp, MonadIO m)
+ => String -- ^ From user (name only, not email)
+ -> Repository bp -- ^ repository of the issue
+ -> Issue bp -- ^ the issue
+ -> Comment bp -- ^ the new comment which has been made
+ -> m ()
+sendCommentChangeMail un r i com =
+ liftIO $ do
+ let commentMailSummary =
+ printf "[%s/%s] %s (#%d)"
+ (view rOwner r)
+ (view rName r)
+ (view iSummary i)
+ (view iNumber i)
+ commentMailBody =
+ printf (
+ "<p>%s</p>" ++
+ "<p><small>" ++
+ concatMap (\x -> changeText x ++ "<br>") (view cChanges com) ++
+ "</small></p>" ++
+ "<hr>" ++
+ "<p><small>Click <a href=%s>here</a> to " ++
+ "see the issue." ++
+ " Click <a href=%s>here</a> to unsubscribe." ++
+ "</small></p>"
+ ) (view cBody com) (issueURL r i) (issueURL r i ++ "/unsubscribe")
+ mUsers <- mapM getUser (view iSubs i)
+ mcAuthor <- getUser (view cAuthor com)
+ mapM_ (sendMailTo commentMailSummary commentMailBody
+ (Just un))
+ (deleteMaybe mcAuthor . catMaybes $ mUsers) -- makes sure we don't
+ -- send the mail to
+ -- the commenter
+ where
+ changeText ic = case ic of
+ (AddTag str) -> printf "Tag \"%s\" added" str
+ (RemoveTag str) -> printf "Tag \"%s\" removed" str
+ (Summary old new) -> printf ("Summary changed from \"%s\" to" ++
+ " \"%s\"") old new
+ (Description old new) -> printf ("Description changed from \"%s\"" ++
+ " to \"%s\"") old new
+ (AddBundle _ _) -> printf "Bundle added"
+ (Closed True) -> printf "Issue closed"
+ (Closed False) -> printf "Issue reopened"
+
+
+-- |Sends a reset mail with the given recovery string from 'createFpForUser'
+-- which will be embedded into a working recovery link.
+sendPwResetMail :: (?settings :: Settings, BP bp, BTIO bt, MonadIO m)
+ => String -- ^ recovery string from 'createFpForUser'
+ -> User bp -- ^ user to reset pw and send mail to
+ -> m ()
+sendPwResetMail str u =
+ liftIO $ do
+ let resetPWMailSummary = "Reset Password"
+ resetPWBMailody =
+ printf "<a href=\"%srecovery?fpid=%s\">reset password</a>"
+ baseUrl str
+ sendMailTo resetPWMailSummary resetPWBMailody Nothing u
+
+
+-- |Sends an admin mail with the specified summary, body and recipient.
+-- If the 'fromU' argument is not Nothing, then it will be used to determine
+-- the name in the "From" field. The mail is still the admin mail specified
+-- in darcsden.conf.
+sendMailTo :: (?settings :: Settings, BP bp, MonadIO m)
+ => String -- ^ summary
+ -> String -- ^ body
+ -> Maybe String -- ^ from user (name only),
+ -- ^ pass Nothing for config default
+ -> User bp -- ^ recipient
+ -> m ()
+sendMailTo summary body fromUn u =
+ liftIO $ do
+ let fromUser = fromMaybe sendName fromUn
+ mail <- simpleMail
+ (Address (Just . pack $ view uName u) (pack $ view uEmail u))
+ (Address (Just . pack $ fromUser) (pack sendEmail))
+ (pack summary)
+ DTL.empty
+ (DTL.pack body)
+ []
+ renderSendMail mail
diff -rN -u old-darcsden-mail-notify/src/DarcsDen/Pages/RepoPages.hs new-darcsden-mail-notify/src/DarcsDen/Pages/RepoPages.hs
--- old-darcsden-mail-notify/src/DarcsDen/Pages/RepoPages.hs 2015-11-28 17:12:28.616399280 +0100
+++ new-darcsden-mail-notify/src/DarcsDen/Pages/RepoPages.hs 2015-11-28 17:12:28.618399280 +0100
@@ -390,7 +390,7 @@
<%
case sUser s of
- Just _ ->
+ Just user ->
<div class="issue-revise">
<div class="issue-tags">
{-
@@ -416,6 +416,28 @@
<input type="text" id="tag-name" name="add-tag" placeholder="tag:value" />
<input type="submit" id="add-tag-submit" maxlength="1000" value="add" />
</form>
+ <% if elem user $ view iSubs i
+ then
+ <form class="add-sub" action=(pack unsub) method="post">
+
+ <input type="submit"
+ id="submit-subscription"
+ name="submit"
+ maxlength="1000"
+ value="unsubscribe"
+ />
+ </form>
+ else
+ <form class="add-sub" action=(pack sub) method="post">
+
+ <input type="submit"
+ id="submit-subscription"
+ name="submit"
+ maxlength="1000"
+ value="subscribe"
+ />
+ </form>
+ %>
</div>
<form class="issue-comment" action=(pack add) method="post" enctype="multipart/form-data">
@@ -443,7 +465,6 @@
<input type="submit" name="submit" id="submit-comment" value="comment/update" />
<input type="submit" name="submit" id="submit-close" value=(pack $ if view iIsClosed i then "and reopen" else "and close") />
</div>
-
<input type="hidden" name="tags" id="tags" />
</fieldset>
</form>
@@ -458,6 +479,8 @@
s
where
add = issueURL r i ++ "/comment"
+ sub = issueURL r i ++ "/subscribe"
+ unsub = issueURL r i ++ "/unsubscribe"
renderComment c =
<li class="comment">
diff -rN -u old-darcsden-mail-notify/src/DarcsDen/State/Issue.hs new-darcsden-mail-notify/src/DarcsDen/State/Issue.hs
--- old-darcsden-mail-notify/src/DarcsDen/State/Issue.hs 2015-11-28 17:12:28.616399280 +0100
+++ new-darcsden-mail-notify/src/DarcsDen/State/Issue.hs 2015-11-28 17:12:28.618399280 +0100
@@ -5,11 +5,15 @@
, issueKey, issueData
, iNumber, iSummary, iOwner, iDescription
, iTags, iBundle, iCreated, iUpdated, iIsClosed, iRepository
+ , iSubs
, issueURL, issueRef
+ , isSubbed, isUnSubbed
+ , addSub, rmSub
) where
-import Control.Lens (Simple, Lens, lens, view)
+import Control.Lens (Simple, Lens, lens, set, view)
import Control.Monad.Trans
+import Data.List (delete)
import Data.Time (UTCTime, formatTime)
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale)
@@ -63,6 +67,7 @@
{ _idNumber :: Int
, _idSummary :: String
, _idOwner :: String
+ , _idSubs :: [String]
, _idDescription :: String
, _idTags :: [String]
, _idBundle :: Maybe Int
@@ -88,6 +93,7 @@
:: Int -- ^Number
-> String -- ^Summary
-> String -- ^Owner
+ -> [String] -- ^Subscribers
-> String -- ^Description
-> [String] -- ^Tags
-> Maybe Int -- ^Bundle
@@ -97,13 +103,14 @@
-> RepositoryRefKey bp -- ^Repository
-> IssueData bp
freshIssueData
- number summary owner description tags
+ number summary owner subs description tags
bundle created updated isClosed repository
=
IssueData
{ _idNumber = number
, _idSummary = summary
, _idOwner = owner
+ , _idSubs = subs
, _idDescription = description
, _idTags = tags
, _idBundle = bundle
@@ -130,6 +137,9 @@
idOwner :: Simple Lens (IssueData bp) String
idOwner = lens _idOwner (\isd v -> isd { _idOwner = v })
+idSubs :: Simple Lens (IssueData bp) [String]
+idSubs = lens _idSubs (\isd v -> isd { _idSubs = v })
+
idDescription :: Simple Lens (IssueData bp) String
idDescription = lens _idDescription (\isd v -> isd { _idDescription = v })
@@ -162,6 +172,9 @@
iOwner :: Simple Lens (Issue bp) String
iOwner = issueData . idOwner
+iSubs :: Simple Lens (Issue bp) [String]
+iSubs = issueData . idSubs
+
iDescription :: Simple Lens (Issue bp) String
iDescription = issueData . idDescription
@@ -192,6 +205,7 @@
number <- getAttrOr o "number" 0
summary <- getAttr o "summary"
owner <- getAttr o "owner"
+ subs <- getAttrOr o "subscribers" []
description <- getAttr o "description"
tags <- getAttr o "tags"
bundle <- getAttrOr o "bundle" Nothing
@@ -203,6 +217,7 @@
{ _idNumber = number
, _idSummary = summary
, _idOwner = owner
+ , _idSubs = subs
, _idDescription = description
, _idTags = tags
, _idBundle = bundle
@@ -219,6 +234,7 @@
[ ("number", showJSON (view idNumber isd))
, ("summary", showJSON (view idSummary isd))
, ("owner", showJSON (view idOwner isd))
+ , ("subscribers", showJSON (view idSubs isd))
, ("description", showJSON (view idDescription isd))
, ("tags", showJSON (view idTags isd))
, ("bundle", showJSON (view idBundle isd))
@@ -236,3 +252,36 @@
issueURL r i =
repoURL r ++ "/issue/" ++ show (view iNumber i)
+
+-- |Check whether a given user is subscribed to the given issue.
+isSubbed :: BPIssue bp
+ => String -- ^ user name
+ -> Issue bp
+ -> Bool
+isSubbed sub issue = sub `elem` view iSubs issue
+
+
+-- |Check whether a given user is unsubscribed to the given issue.
+isUnSubbed :: BPIssue bp
+ => String -- ^ user name
+ -> Issue bp
+ -> Bool
+isUnSubbed sub issue = not . isSubbed sub $ issue
+
+
+-- |Add a subscriber to an issue.
+addSub :: BPIssue bp
+ => String -- ^ user name
+ -> Issue bp -- ^ old issue
+ -> Issue bp -- ^ new issue
+addSub sub issue
+ | isSubbed sub issue = issue
+ | otherwise = set iSubs (sub : view iSubs issue) issue
+
+
+-- |Remove a subscriber from an issue.
+rmSub :: BPIssue bp
+ => String -- ^ user name
+ -> Issue bp -- ^ old issue
+ -> Issue bp -- ^ new issue
+rmSub sub issue = set iSubs (delete sub $ view iSubs issue) issue
diff -rN -u old-darcsden-mail-notify/src/DarcsDen/Util.hs new-darcsden-mail-notify/src/DarcsDen/Util.hs
--- old-darcsden-mail-notify/src/DarcsDen/Util.hs 2015-11-28 17:12:28.616399280 +0100
+++ new-darcsden-mail-notify/src/DarcsDen/Util.hs 2015-11-28 17:12:28.617399280 +0100
@@ -6,6 +6,7 @@
import Control.Monad (unless, when, mzero, MonadPlus)
import Control.Monad.Trans
import Data.Char (isAlphaNum, isSpace)
+import Data.List (delete)
import Snap.Core (rqPathInfo, urlEncode, urlDecode)
import qualified Snap.Core as Snap
import System.Directory
@@ -181,3 +182,8 @@
when' b x
| b = x
| otherwise = mzero
+
+
+-- |Delete an element that maybe exists from a list.
+deleteMaybe :: Eq a => Maybe a -> [a] -> [a]
+deleteMaybe m xs = maybe xs (`delete` xs) m
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment