We are no longer offering accounts on this server. Consider https://gitlab.freedesktop.org/ as a place to host projects.

Commit 4f1edf2d authored by David L. L. Thomas's avatar David L. L. Thomas

Merging "Support email notifications"

parent c7638493
......@@ -347,5 +347,5 @@ forkEventHandler app@App{..} = void . forkIO . forever $ do
handleNEvents n = atomically (tryReadTChan appEventChan) >>= \case
Nothing -> return ()
Just event -> do
mapM_ (runDaemon app) (appEventHandlers <*> [event])
mapM_ (runDaemon app) (appEventHandlers settings <*> [event])
handleNEvents (n-1)
......@@ -64,7 +64,8 @@ data App = App
, persistConfig :: Settings.PersistConf
, appLogger :: Logger
, appEventChan :: TChan SnowdriftEvent
, appEventHandlers :: [SnowdriftEvent -> Daemon ()]
, appEventHandlers :: AppConfig DefaultEnv Extra
-> [SnowdriftEvent -> Daemon ()]
}
plural :: Integral i => i -> Text -> Text -> Text
......@@ -305,7 +306,7 @@ snowdriftAuthHashDB =
<form .form-horizontal method="post" action="@{toMaster loginRoute}">
<div .form-group>
<label .col-sm-4 .control-label>
E-mail or handle:
Handle:
<div .col-sm-8>
<input .form-control id="x" name="username" autofocus="" required>
<div .form-group>
......@@ -330,7 +331,7 @@ instance YesodAuth App where
maybe_user_id <- runDB $ getBy $ UniqueUser $ credsIdent creds
case maybe_user_id of
Just (Entity user_id _) -> return $ Just user_id
Nothing -> createUser (credsIdent creds) Nothing Nothing Nothing Nothing
Nothing -> createUser (credsIdent creds) Nothing Nothing Nothing Nothing Nothing
-- You can add other plugins like BrowserID, email or OAuth here
authPlugins _ = [ snowdriftAuthBrowserId, snowdriftAuthHashDB ]
......@@ -344,13 +345,14 @@ instance YesodAuth App where
lift $ defaultLayout $(widgetFile "auth")
createUser :: Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Handler (Maybe UserId)
createUser ident passwd name avatar nick = do
createUser :: Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text
-> Maybe Text -> Handler (Maybe UserId)
createUser ident passwd name email avatar nick = do
now <- liftIO getCurrentTime
handle (\DBException -> return Nothing) $ runYDB $ do
account_id <- insert (Account 0)
discussion_id <- insert (Discussion 0)
user <- maybe return setPassword passwd $ User ident (Just now) Nothing Nothing name account_id avatar Nothing Nothing nick now now EstUnestablished discussion_id
user <- maybe return setPassword passwd $ User ident email (Just now) Nothing Nothing name account_id avatar Nothing Nothing nick now now EstUnestablished discussion_id
uid_maybe <- insertUnique user
Entity snowdrift_id _ <- getBy404 $ UniqueProjectHandle "snowdrift"
case uid_maybe of
......@@ -375,11 +377,26 @@ createUser ident passwd name avatar nick = do
insert_ $ Notification now NotifWelcome user_id (Just snowdrift_id) notif_text False
return $ Just user_id
Nothing -> do
lift $ addAlert "danger" "E-mail or handle already in use."
lift $ addAlert "danger" "Handle already in use."
throwIO DBException
where
insertDefaultNotificationPrefs :: UserId -> DB ()
insertDefaultNotificationPrefs user_id = insert_ (UserNotificationPref user_id NotifReply NotifDeliverInternal)
insertDefaultNotificationPrefs user_id =
void . insertMany $ uncurry (UserNotificationPref user_id) <$>
-- 'NotifWelcome' is not set since it is delivered when a
-- user is created.
[ (NotifEligEstablish, NotifDeliverInternal)
, (NotifEligEstablish, NotifDeliverEmail)
, (NotifBalanceLow, NotifDeliverInternal)
, (NotifBalanceLow, NotifDeliverEmail)
, (NotifUnapprovedComment, NotifDeliverEmail)
, (NotifRethreadedComment, NotifDeliverInternal)
, (NotifReply, NotifDeliverEmail)
, (NotifEditConflict, NotifDeliverInternal)
, (NotifFlag, NotifDeliverInternal)
, (NotifFlag, NotifDeliverEmail)
, (NotifFlagRepost, NotifDeliverInternal)
]
instance YesodJquery App
......
......@@ -7,6 +7,7 @@ import Handler.Comment
import Handler.Discussion
import Handler.User.Comment
import Model.Comment.ActionPermissions
import Model.Notification.Internal (NotificationType (..))
import Model.Role
import Model.Transaction
import Model.User
......@@ -75,10 +76,11 @@ postUserCreateR = do
((result, form), _) <- runFormPost $ createUserForm Nothing
case result of
FormSuccess (ident, passwd, name, avatar, nick) -> do
createUser ident (Just passwd) name avatar nick >>= \ maybe_user_id -> when (isJust maybe_user_id) $ do
setCreds True $ Creds "HashDB" ident []
redirectUltDest HomeR
FormSuccess (ident, passwd, name, email, avatar, nick) -> do
createUser ident (Just passwd) name email avatar nick
>>= \ maybe_user_id -> when (isJust maybe_user_id) $ do
setCreds True $ Creds "HashDB" ident []
redirectUltDest HomeR
FormMissing -> alertDanger "missing field"
FormFailure strings -> alertDanger (mconcat strings)
......@@ -316,7 +318,8 @@ postUserEstEligibleR user_id = do
user <- runYDB (get404 user_id)
case userEstablished user of
EstUnestablished -> do
runSDB (eligEstablishUserDB establisher_id user_id reason)
honor_pledge <- getUrlRender >>= \r -> return $ r HonorPledgeR
runSDB $ eligEstablishUserDB honor_pledge establisher_id user_id reason
setMessage "This user is now eligible for establishment. Thanks!"
redirectUltDest HomeR
_ -> error "User not unestablished!"
......@@ -392,3 +395,40 @@ getUserTicketsR user_id = do
$(widgetFile "user_tickets")
--------------------------------------------------------------------------------
-- /#UserId/notifications
getUserNotificationsR :: UserId -> Handler Html
getUserNotificationsR user_id = do
void $ checkEditUser user_id
user <- runYDB $ get404 user_id
let fetchNotifPref = runYDB . fetchUserNotificationPrefDB user_id
mbal <- fetchNotifPref NotifBalanceLow
mucom <- fetchNotifPref NotifUnapprovedComment
mrcom <- fetchNotifPref NotifRethreadedComment
mrep <- fetchNotifPref NotifReply
mecon <- fetchNotifPref NotifEditConflict
mflag <- fetchNotifPref NotifFlag
mflagr <- fetchNotifPref NotifFlagRepost
(form, enctype) <- generateFormPost $
userNotificationsForm mbal mucom mrcom mrep mecon mflag mflagr
defaultLayout $ do
setTitle . toHtml $ "Notification preferences - " <>
userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
$(widgetFile "user_notifications")
postUserNotificationsR :: UserId -> Handler Html
postUserNotificationsR user_id = do
void $ checkEditUser user_id
((result, form), enctype) <- runFormPost $
userNotificationsForm Nothing Nothing Nothing Nothing
Nothing Nothing Nothing
case result of
FormSuccess notif_pref -> do
runDB $ updateNotificationPrefDB user_id notif_pref
alertSuccess "Successfully updated the notification preferences."
redirect $ UserR user_id
_ -> do
alertDanger $ "Failed to update the notification preferences. "
<> "Please try again."
defaultLayout $(widgetFile "user_notifications")
......@@ -145,14 +145,15 @@ postWikiR project_handle target = do
where_ $ edit ^. WikiEditId ==. val (wikiLastEditEdit last_edit)
return $ edit ^. WikiEditUser
wiki <- getUrlRender <*> (pure $ WikiR project_handle target)
let comment_body = Markdown $ T.unlines
[ "ticket: edit conflict"
, ""
, "[original version](" <> target <> "/h/" <> toPathPiece last_edit_id <> ")"
, "[original version](" <> wiki <> "/h/" <> toPathPiece last_edit_id <> ")"
, ""
, "[my version](" <> target <> "/h/" <> toPathPiece edit_id <> ")"
, "[my version](" <> wiki <> "/h/" <> toPathPiece edit_id <> ")"
, ""
, "[their version](" <> target <> "/h/" <> toPathPiece (wikiLastEditEdit last_edit) <> ")"
, "[their version](" <> wiki <> "/h/" <> toPathPiece (wikiLastEditEdit last_edit) <> ")"
, ""
, "(this ticket was automatically generated)"
]
......@@ -167,8 +168,10 @@ postWikiR project_handle target = do
, "<br>[**Ticket created**](" <> render (WikiCommentR project_handle target comment_id) [] <> ")"
]
sendNotificationDB_ NotifEditConflict last_editor Nothing notif_text
sendNotificationDB_ NotifEditConflict user_id Nothing notif_text
sendPreferredNotificationDB last_editor NotifEditConflict
Nothing Nothing notif_text
sendPreferredNotificationDB user_id NotifEditConflict
Nothing Nothing notif_text
lift (lift (alertDanger "conflicting edits (ticket created, notification sent)"))
......
......@@ -62,6 +62,7 @@ import Import
import Model.Comment.Sql
import Model.Discussion
import Model.Notification
import Model.User.Internal (sendPreferredNotificationDB)
import Model.Utils
import qualified Control.Monad.State as State
......@@ -319,7 +320,7 @@ editCommentDB comment_id text = do
rendered_route <- lift (makeCommentRouteDB comment_id >>= lift . routeToText . fromJust)
let notif_text = Markdown $ "A comment you flagged has been edited and reposted to the site. You can view it [here](" <> rendered_route <> ")."
lift (deleteCascade comment_flagging_id) -- delete flagging and all flagging reasons with it.
sendNotificationDB_ NotifFlagRepost commentFlaggingFlagger Nothing notif_text
sendPreferredNotificationDB commentFlaggingFlagger NotifFlagRepost Nothing Nothing notif_text
where
updateCommentText =
update $ \c -> do
......@@ -346,7 +347,7 @@ flagCommentDB comment_id permalink_route flagger_id reasons message = do
, ""
, "[link to flagged comment](" <> permalink_route <> ")"
]
sendNotificationDB_ NotifFlag poster_id Nothing notif_text
sendPreferredNotificationDB poster_id NotifFlag Nothing Nothing notif_text
return True
-- | Post an new (approved) Comment.
......
......@@ -2,6 +2,7 @@ module Model.Notification
( archiveNotificationDB
, sendNotificationDB
, sendNotificationDB_
, sendNotificationEmailDB
, module Model.Notification.Internal
) where
......@@ -10,6 +11,7 @@ import Import
import Model.Notification.Internal
import Control.Monad.Writer.Strict (tell)
import Data.Maybe (fromJust)
-- | Archive a notification.
archiveNotificationDB :: NotificationId -> DB ()
......@@ -19,13 +21,25 @@ archiveNotificationDB notif_id =
where_ (n ^. NotificationId ==. val notif_id)
-- | Send a notification to a user.
sendNotificationDB :: NotificationType -> UserId -> Maybe ProjectId -> Markdown -> SDB NotificationId
sendNotificationDB notif_type user_id mproject_id content = do
sendNotificationDB :: NotificationType -> UserId -> Maybe ProjectId
-> Maybe CommentId -> Markdown -> SDB NotificationId
sendNotificationDB notif_type user_id mproject_id mcomment_id content = do
now <- liftIO getCurrentTime
let notif = Notification now notif_type user_id mproject_id content False
notif_id <- lift (insert notif)
-- Record the fact that we send this notification, so we can
-- delete it when the comment is approved.
when (notif_type == NotifUnapprovedComment && isJust mcomment_id) $
insert_ $ UnapprovedCommentNotification (fromJust mcomment_id) notif_id
tell [ENotificationSent notif_id notif]
return notif_id
sendNotificationDB_ :: NotificationType -> UserId -> Maybe ProjectId -> Markdown -> SDB ()
sendNotificationDB_ notif_type user_id mproject_id content = void (sendNotificationDB notif_type user_id mproject_id content)
sendNotificationDB_ :: NotificationType -> UserId -> Maybe ProjectId
-> Maybe CommentId -> Markdown -> SDB ()
sendNotificationDB_ notif_type user_id mproject_id mcomment_id content = void $ sendNotificationDB notif_type user_id mproject_id mcomment_id content
sendNotificationEmailDB :: NotificationType -> UserId -> Maybe ProjectId
-> Markdown -> DB ()
sendNotificationEmailDB notif_type user_id mproject_id content = do
now <- liftIO getCurrentTime
insert_ $ NotificationEmail now notif_type user_id mproject_id content
......@@ -41,6 +41,7 @@ showNotificationType NotifFlagRepost = "A comment you flagged was edited
data NotificationDelivery
= NotifDeliverInternal -- Only send notifications.
| NotifDeliverEmail -- Send email in addition to notifications.
| NotifDeliverEmailDigest -- Send email digest in addition to notifications (sent immediately).
deriving (Read, Show)
-- XXX: Not supported by 'userNotificationsForm'.
-- | NotifDeliverEmailDigest -- Send email digest in addition to notifications (sent immediately).
deriving (Read, Show, Eq)
derivePersistField "NotificationDelivery"
......@@ -26,7 +26,9 @@ module Model.User
, fetchUserProjectsAndRolesDB
, fetchUserRolesDB
, fetchUsersInDB
, sendPreferredNotificationDB
, updateUserDB
, updateNotificationPrefDB
, userCanDeleteCommentDB
, userClaimCommentDB
, userHasRoleDB
......@@ -61,9 +63,10 @@ import Model.User.Internal
import Model.User.Sql
import Model.Wiki.Sql
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Control.Monad.Writer.Strict (tell)
import Yesod.Markdown (Markdown(..))
......@@ -122,6 +125,7 @@ updateUserPreview :: UserUpdate -> User -> User
updateUserPreview UserUpdate{..} user = user
{ userName = userUpdateName
, userAvatar = userUpdateAvatar
, userEmail = userUpdateEmail
, userIrcNick = userUpdateIrcNick
, userStatement = userUpdateStatement
, userBlurb = userUpdateBlurb
......@@ -138,20 +142,13 @@ updateUserDB user_id UserUpdate{..} = do
update $ \u -> do
set u $ [ UserName =. val userUpdateName
, UserAvatar =. val userUpdateAvatar
, UserEmail =. val userUpdateEmail
, UserIrcNick =. val userUpdateIrcNick
, UserStatement =. val userUpdateStatement
, UserBlurb =. val userUpdateBlurb
]
where_ (u ^. UserId ==. val user_id)
-- This stuff sets notification prefs (although might be only half-way
-- complete):
delete $
from $ \ump -> do
where_ (ump ^. UserNotificationPrefUser ==. val user_id)
-- let new_prefs = map (uncurry (UserNotificationPref user_id)) userUpdateNotificationPreferences
-- void (insertMany new_prefs)
-- | Establish a user, given their eligible-timestamp and reason for
-- eligibility. Mark all unapproved comments of theirs as approved.
establishUserDB :: UserId -> UTCTime -> Text -> DB ()
......@@ -177,8 +174,8 @@ establishUserDB user_id elig_time reason = do
-- | Make a user eligible for establishment. Put a notification in their inbox
-- instructing them to read and accept the honor pledge.
eligEstablishUserDB :: UserId -> UserId -> Text -> SDB ()
eligEstablishUserDB establisher_id user_id reason = do
eligEstablishUserDB :: Text -> UserId -> UserId -> Text -> SDB ()
eligEstablishUserDB honor_pledge establisher_id user_id reason = do
elig_time <- liftIO getCurrentTime
let est = EstEligible elig_time reason
lift $
......@@ -189,13 +186,15 @@ eligEstablishUserDB establisher_id user_id reason = do
lift $ insert_ $ ManualEstablishment user_id establisher_id
snowdrift_id <- lift getSnowdriftId
sendNotificationDB_ NotifEligEstablish user_id (Just snowdrift_id) content
sendPreferredNotificationDB user_id NotifEligEstablish
(Just snowdrift_id) Nothing content
where
content :: Markdown
content = Markdown $ T.unlines
[ "You are now eligible to become an *established* user."
, ""
, "After you [accept the honor pledge](/honor-pledge), you can comment and take other actions on the site without moderation."
, "After you [accept the honor pledge](" <> honor_pledge <>
"), you can comment and take other actions on the site without moderation."
]
-- | Get a User's Roles in a Project.
......@@ -268,18 +267,6 @@ canMakeEligible establishee_id establisher_id = do
<*> (elem Moderator <$> fetchAllUserRolesDB establisher_id)
return $ userIsUnestablished establishee && establisher_is_mod
-- | How does this User prefer notifications of a certain type to be delivered (if at all)?
-- listToMaybe is appropriate here due to UniqueUserNotificationPref (list returned will
-- either be [] or [Value delivery])
fetchUserNotificationPrefDB :: UserId -> NotificationType -> DB (Maybe NotificationDelivery)
fetchUserNotificationPrefDB user_id notif_type = fmap (fmap unValue . listToMaybe) $
select $
from $ \unp -> do
where_ $
unp ^. UserNotificationPrefUser ==. val user_id &&.
unp ^. UserNotificationPrefType ==. val notif_type
return (unp ^. UserNotificationPrefDelivery)
-- | Fetch a User's unarchived private Notifications.
fetchUserNotificationsDB :: UserId -> DB [Entity Notification]
fetchUserNotificationsDB = fetchNotifs (not_ . (^. NotificationArchived))
......@@ -299,6 +286,28 @@ fetchNotifs cond user_id =
orderBy [desc (n ^. NotificationCreatedTs)]
return n
updateNotificationPrefDB :: UserId -> NotificationPref -> DB ()
updateNotificationPrefDB user_id NotificationPref {..} = do
updateNotifPrefs NotifBalanceLow notifBalanceLow
updateNotifPrefs NotifUnapprovedComment notifUnapprovedComment
deleteOrUpdateNotifPrefs NotifRethreadedComment notifRethreadedComment
deleteOrUpdateNotifPrefs NotifReply notifReply
updateNotifPrefs NotifEditConflict notifEditConflict
updateNotifPrefs NotifFlag notifFlag
deleteOrUpdateNotifPrefs NotifFlagRepost notifFlagRepost
where
delete' notif_type =
delete $ from $ \unp ->
where_ $ unp ^. UserNotificationPrefUser ==. val user_id
&&. unp ^. UserNotificationPrefType ==. val notif_type
updateNotifPrefs notif_type delivery = do
delete' notif_type
F.forM_ delivery $ insert_ . UserNotificationPref user_id notif_type
deleteOrUpdateNotifPrefs notif_type delivery =
maybe (delete' notif_type)
(updateNotifPrefs notif_type)
delivery
userWatchProjectDB :: UserId -> ProjectId -> DB ()
userWatchProjectDB user_id project_id = void (insertUnique (UserWatchingProject user_id project_id))
......
module Model.User.Internal where
import Prelude
import Import
import Model.Notification
( NotificationType (..), NotificationDelivery (..)
, sendNotificationDB_, sendNotificationEmailDB )
import Data.Text (Text)
import Yesod.Markdown (Markdown)
import qualified Data.Foldable as F
import qualified Data.List.NonEmpty as N
import Data.List.NonEmpty (NonEmpty)
data UserUpdate =
UserUpdate
{ userUpdateName :: Maybe Text
, userUpdateAvatar :: Maybe Text
, userUpdateEmail :: Maybe Text
, userUpdateIrcNick :: Maybe Text
, userUpdateBlurb :: Maybe Markdown
, userUpdateStatement :: Maybe Markdown
-- , userUpdateNotificationPreferences :: [(NotificationType, NotificationDelivery)]
}
data NotificationPref = NotificationPref
{ -- 'NotifWelcome' and 'NotifEligEstablish' are not handled since
-- they are delivered only once.
notifBalanceLow :: NonEmpty NotificationDelivery
, notifUnapprovedComment :: NonEmpty NotificationDelivery
, notifRethreadedComment :: Maybe (NonEmpty NotificationDelivery)
, notifReply :: Maybe (NonEmpty NotificationDelivery)
, notifEditConflict :: NonEmpty NotificationDelivery
, notifFlag :: NonEmpty NotificationDelivery
, notifFlagRepost :: Maybe (NonEmpty NotificationDelivery)
} deriving Show
-- | How does this User prefer notifications of a certain type to be delivered?
fetchUserNotificationPrefDB :: UserId -> NotificationType -> DB (Maybe (NonEmpty NotificationDelivery))
fetchUserNotificationPrefDB user_id notif_type
= (\case [] -> Nothing
xs -> Just $ unValue <$> N.fromList xs)
<$> (select $
from $ \unp -> do
where_ $
unp ^. UserNotificationPrefUser ==. val user_id &&.
unp ^. UserNotificationPrefType ==. val notif_type
return (unp ^. UserNotificationPrefDelivery))
fetchUserEmail :: UserId -> DB (Maybe Text)
fetchUserEmail user_id
= (\case [] -> Nothing
(x:_) -> unValue x)
<$> (select $ from $ \user -> do
where_ $ user ^. UserId ==. val user_id
return $ user ^. UserEmail)
-- | Perform an action (or actions) according to the selected
-- 'NotificationDelivery' method.
sendPreferredNotificationDB :: UserId -> NotificationType -> Maybe ProjectId
-> Maybe CommentId-> Markdown -> SDB ()
sendPreferredNotificationDB user_id notif_type mproject_id mcomment_id content = do
mprefs <- lift $ fetchUserNotificationPrefDB user_id notif_type
F.forM_ mprefs $ \prefs -> F.forM_ prefs $ \pref -> do
muser_email <- lift $ fetchUserEmail user_id
-- XXX: Support 'NotifDeliverEmailDigest'.
if | pref == NotifDeliverEmail && isJust muser_email ->
lift $ sendNotificationEmailDB notif_type user_id mproject_id content
| otherwise ->
sendNotificationDB_ notif_type user_id mproject_id mcomment_id content
......@@ -184,6 +184,7 @@ library
, random
, regex-tdfa
, resourcet
, semigroups
, shakespeare
, shakespeare-css
, shakespeare-js
......@@ -259,6 +260,68 @@ executable Snowdrift
ghc-options: -threaded -O2
executable SnowdriftEmailDaemon
if flag(dev)
ghc-options: -Wall
if flag(library-only)
Buildable: False
main-is: SnowdriftEmailDaemon.hs
build-depends: base
, authenticate
, blaze-builder
, blaze-html
, blaze-markup
, bytestring
, containers
, cmdargs
, data-default
, Diff
, esqueleto
, email-validate
, fast-logger
, hjsmin
, http-conduit
, lifted-base
, mime-mail
, monad-logger
, mtl
, path-pieces
, persistent
, persistent-postgresql
, persistent-template
, resourcet
, shakespeare
, stm
, template-haskell
, text
, time
, yaml
, yesod
, yesod-auth
, yesod-auth-hashdb
, yesod-core
, yesod-form
, yesod-markdown
, yesod-static
extensions: BangPatterns
ConstraintKinds
DeriveDataTypeable
EmptyDataDecls
ExistentialQuantification
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
MultiParamTypeClasses
MultiWayIf
NoImplicitPrelude
QuasiQuotes
OverloadedStrings
RankNTypes
RecordWildCards
ScopedTypeVariables
TemplateHaskell
TypeFamilies
executable sdm
if flag(dev)
ghc-options: -Wall
......
This diff is collapsed.
......@@ -11,62 +11,58 @@ import Model.Project
import Model.User
import Model.Utils
import qualified Data.Foldable as F
import Data.Maybe (fromJust)
import qualified Database.Persist
import Yesod.Default.Config (AppConfig (..), DefaultEnv (..))
import Yesod.Markdown
-- Add more event handlers here.
snowdriftEventHandlers :: [SnowdriftEvent -> Daemon ()]
snowdriftEventHandlers =
[ notificationEventHandler
snowdriftEventHandlers :: AppConfig DefaultEnv Extra
-> [SnowdriftEvent -> Daemon ()]
snowdriftEventHandlers conf =
[ notificationEventHandler conf
, eventInserterHandler
]
-- | Handler in charge of sending Notifications to interested parties.
notificationEventHandler :: SnowdriftEvent -> Daemon ()
notificationEventHandler :: AppConfig DefaultEnv Extra
-> SnowdriftEvent -> Daemon ()
-- Notify the comment's parent's poster that their comment has been replied to (per their preferences).
notificationEventHandler (ECommentPosted comment_id comment) = case commentParent comment of
notificationEventHandler AppConfig{..} (ECommentPosted comment_id comment) = case commentParent comment of
Nothing -> return ()
Just parent_comment_id -> do
(parent_user_id, delivery) <- runDB $ do
parent_comment_route <- routeToText $ CommentDirectLinkR parent_comment_id
reply_comment_route <- routeToText $ CommentDirectLinkR comment_id
runSDB $ do
parent_user_id <- commentUser <$> Database.Persist.getJust parent_comment_id
delivery <- fetchUserNotificationPrefDB parent_user_id NotifReply
return (parent_user_id, delivery)
-- Any non-Nothing delivery implies an internal Notification should be sent.
when (isJust delivery) $ do
parent_comment_route <- routeToText (CommentDirectLinkR parent_comment_id)
reply_comment_route <- routeToText (CommentDirectLinkR comment_id)
let content = mconcat
[ "Someone replied to [your comment]("
, Markdown parent_comment_route
, ")! You can view the reply [here]("
, Markdown reply_comment_route
, ")."
, ""
, "*You can filter these notifications by adjusting the settings in your profile.*"
]
runSDB (sendNotificationDB_ NotifReply parent_user_id Nothing content)
sendPreferredNotificationDB parent_user_id NotifReply Nothing Nothing $
mconcat [ "Someone replied to [your comment]("
, Markdown $ appRoot <> parent_comment_route
, ")! You can view the reply [here]("
, Markdown $ appRoot <> reply_comment_route
, "). *You can filter these notifications by " <>
"adjusting the settings in your profile.*"
]
-- Notify all moderators of the project the comment was posted on.
notificationEventHandler (ECommentPending comment_id comment) = do
notificationEventHandler AppConfig{..} (ECommentPending comment_id comment) = do
runSDB $ do
discussion <- lift $ fetchDiscussionDB (commentDiscussion comment)
let projectComment (Entity project_id project) = do
route_text <- (lift . lift) (routeToText (CommentDirectLinkR comment_id)) -- TODO(mitchell): don't use direct link?
route_text <- (lift . lift) (routeToText (CommentDirectLinkR comment_id))
let content = mconcat
[ "An unapproved comment has been posted on a "
, Markdown (projectName project)
, " page. Please view it [here]("
, Markdown route_text
, Markdown $ appRoot <> route_text
, ")."
]
lift (fetchProjectModeratorsDB project_id) >>=
-- Send the notification, and record the fact that we send it (so we can
-- later delete it, when the comment is approved).
mapM_ (\user_id -> sendNotificationDB NotifUnapprovedComment user_id Nothing content
>>= insert_ . UnapprovedCommentNotification comment_id)
mods <- lift $ fetchProjectModeratorsDB project_id
F.forM_ mods $ \ user_id -> sendPreferredNotificationDB user_id NotifUnapprovedComment
Nothing (Just comment_id) content
case discussion of
DiscussionOnProject project -> projectComment project
......@@ -82,7 +78,7 @@ notificationEventHandler (ECommentPending comment_id comment) = do
-}
-- Notify the rethreadee his/her comment has been rethreaded.
notificationEventHandler (ECommentRethreaded _ Rethread{..}) = do
notificationEventHandler AppConfig{..} (ECommentRethreaded _ Rethread{..}) = do
(comment, Just old_route, Just new_route) <- runDB $ (,,)
<$> getJust rethreadOldComme