git.gnu.io has moved to IP address 209.51.188.249 -- please double check where you are logging in.

Commit 3038ba23 authored by David L. L. Thomas's avatar David L. L. Thomas

Merge commit 'refs/merge-requests/60' of gitorious.org:snowdrift/snowdrift into merge_request_60

Conflicts:
	Model/User.hs
	Model/User/Internal.hs
	templates/update_shares.hamlet
	tests/NotifyTest.hs
parents b923d38b 561a2dd1
......@@ -23,7 +23,7 @@ import Control.Monad.Writer.Strict (WriterT, runWriterT)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace)
import Data.Int (Int64)
import Data.Maybe (fromJust, mapMaybe)
import Data.Maybe (mapMaybe)
import Data.Monoid
import Data.Time
import Data.Text as T
......@@ -391,7 +391,7 @@ createUser ident passwd name email avatar nick = do
where
insertDefaultNotificationPrefs :: UserId -> DB ()
insertDefaultNotificationPrefs user_id =
void . insertMany $ uncurry (UserNotificationPref user_id) <$>
void . insertMany $ uncurry (UserNotificationPref user_id Nothing) <$>
-- 'NotifWelcome' is not set since it is delivered when a
-- user is created.
[ (NotifBalanceLow, NotifDeliverWebsite)
......@@ -466,11 +466,6 @@ getAlert = do
deleteSession alertKey
return mmsg
-- | Get the ProjectId for the "snowdrift" project. Partial function. Possibly this should
-- be replaced by a hard-coded key? We're hard-coding "snowdrift", anyways.
getSnowdriftId :: DB ProjectId
getSnowdriftId = entityKey . fromJust <$> getBy (UniqueProjectHandle "snowdrift")
-- | Write a list of SnowdriftEvent to the event channel.
pushEvents :: (MonadIO m, MonadReader App m) => [SnowdriftEvent] -> m ()
pushEvents events = ask >>= liftIO . atomically . forM_ events . writeTChan . appEventChan
......
......@@ -204,18 +204,19 @@ getProjectR :: Text -> Handler Html
getProjectR project_handle = do
mviewer_id <- maybeAuthId
(project_id, project, pledges, pledge) <- runYDB $ do
(project_id, project, is_watching, pledges, pledge) <- runYDB $ do
Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle
pledges <- getProjectShares project_id
pledge <- case mviewer_id of
Nothing -> return Nothing
Just viewer_id -> getBy $ UniquePledge viewer_id project_id
return (project_id, project, pledges, pledge)
(pledge, is_watching) <- case mviewer_id of
Nothing -> return (Nothing, False)
Just viewer_id -> (,)
<$> (getBy $ UniquePledge viewer_id project_id)
<*> userIsWatchingProjectDB viewer_id project_id
return (project_id, project, is_watching, pledges, pledge)
defaultLayout $ do
setTitle . toHtml $ projectName project <> " | Snowdrift.coop"
renderProject (Just project_id) project pledges pledge
renderProject (Just project_id) project mviewer_id is_watching pledges pledge
postProjectR :: Text -> Handler Html
postProjectR project_handle = do
......@@ -265,7 +266,7 @@ postProjectR project_handle = do
let preview_project = project { projectName = name, projectDescription = description, projectGithubRepo = github_repo }
(form, _) <- generateFormPost $ editProjectForm (Just (preview_project, tags))
defaultLayout $ previewWidget form "update" $ renderProject (Just project_id) preview_project [] Nothing
defaultLayout $ previewWidget form "update" $ renderProject (Just project_id) preview_project Nothing False [] Nothing
x -> do
alertDanger $ T.pack $ show x
......@@ -839,25 +840,13 @@ getProjectTransactionsR project_handle = do
getWikiPagesR :: Text -> Handler Html
getWikiPagesR project_handle = do
muser_id <- maybeAuthId
void $ maybeAuthId
languages <- getLanguages
-- TODO: should be be using unviewed_comments and unviewed_edits?
(project, wiki_targets, _, _) <- runYDB $ do
(project, wiki_targets) <- runYDB $ do
Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle
wiki_targets <- getProjectWikiPages languages project_id
-- If the user is not logged in or not watching the project, these maps are empty.
(unviewed_comments, unviewed_edits) <- case muser_id of
Nothing -> return (mempty, mempty)
Just user_id -> do
is_watching <- userIsWatchingProjectDB user_id project_id
if is_watching
then (,)
<$> fetchNumUnviewedCommentsOnProjectWikiPagesDB user_id project_id
<*> fetchNumUnviewedWikiEditsOnProjectDB user_id project_id
else return (mempty, mempty)
return (project, wiki_targets, unviewed_comments, unviewed_edits)
return (project, wiki_targets)
defaultLayout $ do
setTitle . toHtml $ projectName project <> " Wiki | Snowdrift.coop"
$(widgetFile "wiki_pages")
......@@ -866,8 +855,8 @@ getWikiPagesR project_handle = do
-- /watch, /unwatch
postWatchProjectR, postUnwatchProjectR :: ProjectId -> Handler ()
postWatchProjectR = watchOrUnwatchProject userWatchProjectDB "watching "
postUnwatchProjectR = watchOrUnwatchProject userUnwatchProjectDB "no longer watching "
postWatchProjectR = watchOrUnwatchProject userWatchProjectDB "Watching "
postUnwatchProjectR = watchOrUnwatchProject userUnwatchProjectDB "No longer watching "
watchOrUnwatchProject :: (UserId -> ProjectId -> DB ()) -> Text -> ProjectId -> Handler ()
watchOrUnwatchProject action msg project_id = do
......@@ -875,8 +864,8 @@ watchOrUnwatchProject action msg project_id = do
project <- runYDB $ do
action user_id project_id
get404 project_id
alertSuccess (msg <> projectName project)
redirect HomeR
alertSuccess (msg <> projectName project <> ".")
redirect $ ProjectR $ projectHandle project
--------------------------------------------------------------------------------
-- /c/#CommentId
......
......@@ -21,11 +21,13 @@ import Widgets.ProjectPledges
import Widgets.Time
import Data.Default (def)
import Data.List (head)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import qualified Data.Maybe as Maybe
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Traversable as Traversable
import Text.Cassius (cassiusFile)
import Yesod.Auth.HashDB (setPassword, validateUser)
......@@ -510,13 +512,13 @@ getUserTicketsR user_id = do
$(widgetFile "user_tickets")
--------------------------------------------------------------------------------
-- /#UserId/notifications
-- /#UserId/user-notifications
getUserNotificationsR :: UserId -> Handler Html
getUserNotificationsR user_id = do
void $ checkEditUser user_id
user <- runYDB $ get404 user_id
let fetchNotifPref = runYDB . fetchUserNotificationPrefDB user_id
let fetchNotifPref = runYDB . fetchUserNotificationPrefDB user_id Nothing
mbal <- fetchNotifPref NotifBalanceLow
mucom <- fetchNotifPref NotifUnapprovedComment
mrcom <- fetchNotifPref NotifRethreadedComment
......@@ -542,7 +544,8 @@ postUserNotificationsR user_id = do
Nothing Nothing Nothing Nothing Nothing Nothing Nothing
case result of
FormSuccess notif_pref -> do
runDB $ updateNotificationPrefDB user_id notif_pref
forM_ (userNotificationPref notif_pref) $ \ (ntype, ndelivs) ->
runDB $ updateNotificationPrefDB user_id Nothing ntype ndelivs
alertSuccess "Successfully updated the notification preferences."
redirect $ UserR user_id
_ -> do
......@@ -550,6 +553,72 @@ postUserNotificationsR user_id = do
<> "Please try again."
defaultLayout $(widgetFile "user_notifications")
--------------------------------------------------------------------------------
-- /#UserId/select-project
getUserSelectProjectR :: UserId -> Handler Html
getUserSelectProjectR user_id = do
void $ checkEditUser user_id
user <- runYDB $ get404 user_id
projects <- runDB $ fetchUserWatchingProjectsDB user_id
if length projects == 1
then redirect $ ProjectNotificationsR user_id $ entityKey $ head projects
else defaultLayout $ do
setTitle $ toHtml $ "Select Project - " <>
userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
$(widgetFile "user_select_project")
postUserSelectProjectR :: UserId -> Handler Html
postUserSelectProjectR user_id = do
void $ checkEditUser user_id
mproject_id <- lookupPostParam "project_id"
maybe (redirect $ UserR user_id)
(redirect . ProjectNotificationsR user_id . Key . PersistInt64)
(join $ Traversable.forM mproject_id $ readMaybe . T.unpack)
--------------------------------------------------------------------------------
-- /#UserId/project-notifications
getProjectNotificationsR :: UserId -> ProjectId -> Handler Html
getProjectNotificationsR user_id project_id = do
void $ checkEditUser user_id
user <- runYDB $ get404 user_id
project <- runYDB $ get404 project_id
let fetchNotifPref =
runYDB . fetchUserNotificationPrefDB user_id (Just project_id)
mwiki_page <- fetchNotifPref NotifWikiPage
mwiki_edit <- fetchNotifPref NotifWikiEdit
mblog_post <- fetchNotifPref NotifBlogPost
mnew_pledge <- fetchNotifPref NotifNewPledge
mupdated_pledge <- fetchNotifPref NotifUpdatedPledge
mdeleted_pledge <- fetchNotifPref NotifDeletedPledge
(form, enctype) <- generateFormPost $
projectNotificationsForm mwiki_page mwiki_edit mblog_post
mnew_pledge mupdated_pledge mdeleted_pledge
defaultLayout $ do
setTitle $ toHtml $ "Notification Preferences for " <>
projectName project <> " - " <> userDisplayName (Entity user_id user) <>
" | Snowdrift.coop"
$(widgetFile "project_notifications")
postProjectNotificationsR :: UserId -> ProjectId -> Handler Html
postProjectNotificationsR user_id project_id = do
void $ checkEditUser user_id
((result, form), enctype) <- runFormPost $
projectNotificationsForm Nothing Nothing Nothing
Nothing Nothing Nothing
case result of
FormSuccess notif_pref -> do
forM_ (projectNotificationPref notif_pref) $ \ (ntype, ndelivs) ->
runDB $ updateNotificationPrefDB
user_id (Just project_id) ntype ndelivs
alertSuccess "Successfully updated the notification preferences."
redirect (UserR user_id)
_ -> do
project <- runYDB $ get404 project_id
alertDanger $ "Failed to update the notification preferences."
defaultLayout $(widgetFile "project_notifications")
--------------------------------------------------------------------------------
-- /#UserId/reset-password/#Text
......
......@@ -603,6 +603,7 @@ getMonolingualWikiR = redirectPolylingualWiki $ \case
Just (NewUserDiscussionR _) -> error "the impossible happened"
Just (UserTicketsR _) -> error "the impossible happened"
Just (UserCommentR _ _) -> error "the impossible happened"
Just (UserSelectProjectR _) -> error "the impossible happened"
Just (ClaimUserCommentR _ _) -> error "the impossible happened"
Just (CloseUserCommentR _ _) -> error "the impossible happened"
Just (DeleteUserCommentR _ _) -> error "the impossible happened"
......@@ -624,6 +625,7 @@ getMonolingualWikiR = redirectPolylingualWiki $ \case
Just (EditUserR _) -> error "the impossible happened"
Just (UserEstEligibleR _) -> error "the impossible happened"
Just (UserNotificationsR _) -> error "the impossible happened"
Just (ProjectNotificationsR _ _) -> error "the impossible happened"
Just (UserPledgesR _) -> error "the impossible happened"
Just (UserResetPasswordR _ _) -> error "the impossible happened"
Just (UserVerifyEmailR _ _) -> error "the impossible happened"
......
......@@ -29,6 +29,14 @@ data NotificationType
| NotifFlag
-- Flagged comment was reposted.
| NotifFlagRepost
-- New wiki page.
| NotifWikiPage
| NotifWikiEdit
-- New blog post.
| NotifBlogPost
| NotifNewPledge
| NotifUpdatedPledge
| NotifDeletedPledge
deriving (Eq, Read, Show, Bounded, Enum)
derivePersistField "NotificationType"
......@@ -43,6 +51,12 @@ showNotificationType NotifReply = "Replies to my comments"
showNotificationType NotifEditConflict = "Edit conflict"
showNotificationType NotifFlag = "A comment of yours was flagged"
showNotificationType NotifFlagRepost = "A comment you flagged was edited and reposted"
showNotificationType NotifBlogPost = "New blog post"
showNotificationType NotifWikiEdit = "Wiki page was edited"
showNotificationType NotifWikiPage = "New wiki page"
showNotificationType NotifNewPledge = "New pledge"
showNotificationType NotifUpdatedPledge = "Pledge updated"
showNotificationType NotifDeletedPledge = "Pledge deleted"
data NotificationDelivery
= NotifDeliverWebsite
......
......@@ -2,6 +2,7 @@ module Model.Project
( ProjectSummary(..)
, UpdateProject(..)
, fetchPublicProjectsDB
, fetchProjectDB
, fetchProjectCommentRethreadEventsBeforeDB
, fetchProjectCommentPostedEventsIncludingRethreadedBeforeDB
, fetchProjectCommentClosingEventsBeforeDB
......@@ -120,6 +121,12 @@ fetchPublicProjectsDB = select $ from $ \ p -> do
where_ $ p ^. ProjectPublic
return p
fetchProjectDB :: ProjectId -> DB [Entity Project]
fetchProjectDB project_id =
select $ from $ \ p -> do
where_ $ p ^. ProjectId ==. val project_id
return p
insertProjectPledgeDB :: UserId
-> ProjectId
-> Int64
......
......@@ -9,6 +9,7 @@ module Model.User
, deleteArchivedNotificationsDB
, deleteNotificationDB
, deleteNotificationsDB
, projectNotificationPref
, updateUserPreview
, userCanAddTag
, userCanCloseComment
......@@ -19,6 +20,7 @@ module Model.User
, userIsModerator
, userIsUnestablished
, userDisplayName
, userNotificationPref
-- Database actions
, archiveNotificationsDB
, deleteFromEmailVerification
......@@ -36,6 +38,8 @@ module Model.User
, fetchUserProjectsAndRolesDB
, fetchUserRolesDB
, fetchUsersInDB
, fetchUsersByNotifPrefDB
, fetchUserWatchingProjectsDB
, fetchVerEmail
, fromEmailVerification
, sendPreferredNotificationDB
......@@ -72,15 +76,14 @@ import Import
import Model.Comment
import Model.Comment.Sql
import Model.Notification
import Model.Project
import Model.Project.Sql
import Model.User.Internal
import Model.User.Internal hiding (UserNotificationPref)
import Model.User.Sql
import Model.Wiki.Sql
import Database.Esqueleto.Internal.Language (From)
import qualified Data.Foldable as F
import qualified Data.List as L
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
......@@ -157,6 +160,14 @@ updateUserPreview UserUpdate{..} user = user
fetchUsersInDB :: [UserId] -> DB [Entity User]
fetchUsersInDB user_ids = selectList [UserId <-. user_ids] []
fetchUserWatchingProjectsDB :: UserId -> DB [Entity Project]
fetchUserWatchingProjectsDB user_id =
select $ from $ \ (uwp,p) -> do
where_ $ uwp ^. UserWatchingProjectUser ==. val user_id
&&. uwp ^. UserWatchingProjectProject ==. p ^. ProjectId
return p
updateUserDB :: UserId -> UserUpdate -> DB ()
updateUserDB user_id UserUpdate{..} = do
update $ \u -> do
......@@ -239,10 +250,8 @@ eligEstablishUserDB honor_pledge establisher_id user_id reason = do
where_ (u ^. UserId ==. val user_id)
lift $ insert_ $ ManualEstablishment user_id establisher_id
snowdrift_id <- lift getSnowdriftId
sendPreferredNotificationDB user_id NotifEligEstablish
(Just snowdrift_id) Nothing content
Nothing Nothing content
where
content :: Markdown
content = Markdown $ T.unlines
......@@ -383,51 +392,34 @@ unarchiveNotificationsDB user_id = do
forM_ notifs $ \(Entity notif_id _) ->
unarchiveNotificationDB notif_id
updateNotificationPrefDB :: UserId -> NotificationPref -> DB ()
updateNotificationPrefDB user_id NotificationPref {..} = do
updateNotifPrefs NotifBalanceLow notifBalanceLow
deleteOrUpdateNotifPrefs NotifUnapprovedComment notifUnapprovedComment
deleteOrUpdateNotifPrefs NotifRethreadedComment notifRethreadedComment
deleteOrUpdateNotifPrefs NotifReply notifReply
updateNotifPrefs NotifEditConflict notifEditConflict
updateNotifPrefs NotifFlag notifFlag
deleteOrUpdateNotifPrefs NotifFlagRepost notifFlagRepost
where
delete' notif_type =
delete $ from $ \unp ->
deleteNotifPrefs :: UserId -> Maybe ProjectId -> NotificationType -> DB ()
deleteNotifPrefs user_id mproject_id notif_type =
delete $ from $ \ unp ->
where_ $ unp ^. UserNotificationPrefUser ==. val user_id
&&. unp ^. UserNotificationPrefProject `notDistinctFrom` val mproject_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))
userUnwatchProjectDB :: UserId -> ProjectId -> DB ()
userUnwatchProjectDB user_id project_id = do
delete_watching
delete_comment_views
delete_wiki_edit_views
where
delete_watching = deleteBy (UniqueUserWatchingProject user_id project_id)
updateNotifPrefs :: UserId -> Maybe ProjectId -> NotificationType
-> NonEmpty NotificationDelivery -> DB ()
updateNotifPrefs user_id mproject_id notif_type notif_delivs = do
deleteNotifPrefs user_id mproject_id notif_type
F.forM_ notif_delivs $
insert_ . UserNotificationPref user_id mproject_id notif_type
delete_comment_views = delete_wiki_page_comment_views
updateNotificationPrefDB :: UserId -> Maybe ProjectId -> NotificationType
-> Maybe (NonEmpty NotificationDelivery) -> DB ()
updateNotificationPrefDB user_id mproject_id notif_type notif_delivs =
maybe (deleteNotifPrefs user_id mproject_id notif_type)
(updateNotifPrefs user_id mproject_id notif_type)
notif_delivs
delete_wiki_page_comment_views = fetchProjectDiscussionsDB project_id >>= \discussion_ids ->
delete $
from $ \(vc `InnerJoin` c) -> do
on_ (vc ^. ViewCommentComment ==. c ^. CommentId)
where_ (c ^. CommentDiscussion `in_` valList discussion_ids)
userWatchProjectDB :: UserId -> ProjectId -> DB ()
userWatchProjectDB user_id project_id =
void $ insertUnique $ UserWatchingProject user_id project_id
delete_wiki_edit_views =
delete $
from $ \vwe ->
where_ (vwe ^. ViewWikiEditEdit `in_` (subList_select (querProjectWikiEdits project_id)))
userUnwatchProjectDB :: UserId -> ProjectId -> DB ()
userUnwatchProjectDB user_id project_id =
deleteBy $ UniqueUserWatchingProject user_id project_id
userIsWatchingProjectDB :: UserId -> ProjectId -> DB Bool
userIsWatchingProjectDB user_id project_id = maybe (False) (const True) <$> getBy (UniqueUserWatchingProject user_id project_id)
......
module Model.User.Internal where
import Prelude
import Import
import Import hiding (UserNotificationPref)
import Model.Notification
( NotificationType (..), NotificationDelivery (..)
, sendNotificationDB_, sendNotificationEmailDB )
......@@ -33,7 +33,7 @@ data SetPassword = SetPassword
, password' :: Text
}
data NotificationPref = NotificationPref
data UserNotificationPref = UserNotificationPref
{ -- 'NotifWelcome' and 'NotifEligEstablish' are not handled since
-- they are delivered only once.
notifBalanceLow :: NonEmpty NotificationDelivery
......@@ -45,10 +45,42 @@ data NotificationPref = NotificationPref
, notifFlagRepost :: Maybe (NonEmpty NotificationDelivery)
} deriving Show
userNotificationPref
:: UserNotificationPref
-> [(NotificationType, Maybe (NonEmpty NotificationDelivery))]
userNotificationPref UserNotificationPref {..} =
[ (NotifBalanceLow , Just notifBalanceLow)
, (NotifUnapprovedComment , notifUnapprovedComment)
, (NotifRethreadedComment , notifRethreadedComment)
, (NotifReply , notifReply)
, (NotifEditConflict , Just notifEditConflict)
, (NotifFlag , Just notifFlag)
, (NotifFlagRepost , notifFlagRepost) ]
data ProjectNotificationPref = ProjectNotificationPref
{ notifWikiPage :: Maybe (NonEmpty NotificationDelivery)
, notifWikiEdit :: Maybe (NonEmpty NotificationDelivery)
, notifBlogPost :: Maybe (NonEmpty NotificationDelivery)
, notifNewPledge :: Maybe (NonEmpty NotificationDelivery)
, notifUpdatedPledge :: Maybe (NonEmpty NotificationDelivery)
, notifDeletedPledge :: Maybe (NonEmpty NotificationDelivery)
} deriving Show
projectNotificationPref
:: ProjectNotificationPref
-> [(NotificationType, Maybe (NonEmpty NotificationDelivery))]
projectNotificationPref ProjectNotificationPref {..} =
[ (NotifWikiEdit , notifWikiEdit)
, (NotifWikiPage , notifWikiPage)
, (NotifBlogPost , notifBlogPost)
, (NotifNewPledge , notifNewPledge)
, (NotifUpdatedPledge , notifUpdatedPledge)
, (NotifDeletedPledge , notifDeletedPledge) ]
forcedNotification :: NotificationType -> Maybe (NonEmpty NotificationDelivery)
forcedNotification NotifWelcome = Just $ return NotifDeliverWebsite
forcedNotification NotifEligEstablish = Just $ return NotifDeliverWebsite
forcedNotification NotifEligEstablish = Just $ N.fromList [ NotifDeliverWebsite, NotifDeliverEmail ]
forcedNotification NotifBalanceLow = Nothing
forcedNotification NotifUnapprovedComment = Nothing
forcedNotification NotifApprovedComment = Nothing
......@@ -57,19 +89,36 @@ forcedNotification NotifReply = Nothing
forcedNotification NotifEditConflict = Nothing
forcedNotification NotifFlag = Nothing
forcedNotification NotifFlagRepost = Nothing
forcedNotification NotifWikiEdit = Nothing
forcedNotification NotifWikiPage = Nothing
forcedNotification NotifBlogPost = Nothing
forcedNotification NotifUpdatedPledge = Nothing
forcedNotification NotifDeletedPledge = Nothing
forcedNotification NotifNewPledge = Nothing
-- | 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 = runMaybeT $ mplus forced pulled
fetchUserNotificationPrefDB :: UserId -> Maybe ProjectId -> NotificationType
-> DB (Maybe (NonEmpty NotificationDelivery))
fetchUserNotificationPrefDB user_id mproject_id notif_type = runMaybeT $ mplus forced pulled
where
forced = MaybeT $ return $ forcedNotification notif_type
pulled = MaybeT $ fmap (N.nonEmpty . unwrapValues) $ select $ from $ \ unp -> do
where_ $ unp ^. UserNotificationPrefUser ==. val user_id
&&. unp ^. UserNotificationPrefProject `notDistinctFrom` val mproject_id
&&. unp ^. UserNotificationPrefType ==. val notif_type
return $ unp ^. UserNotificationPrefDelivery
fetchUsersByNotifPrefDB :: NotificationType -> Maybe ProjectId -> DB [UserId]
fetchUsersByNotifPrefDB notif_type mproject_id =
fmap unwrapValues $
-- A user may select multiple delivery methods, so this query will
-- return duplicates without 'distinct'.
selectDistinct $ from $ \ unp -> do
where_ $ unp ^. UserNotificationPrefType ==. val notif_type
&&. unp ^. UserNotificationPrefProject `notDistinctFrom` val mproject_id
return $ unp ^. UserNotificationPrefUser
fetchUserEmail :: UserId -> DB (Maybe Text)
fetchUserEmail user_id
......@@ -91,7 +140,7 @@ fetchUserEmailVerified user_id =
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
mprefs <- lift $ fetchUserNotificationPrefDB user_id mproject_id notif_type
F.forM_ mprefs $ \ prefs -> F.forM_ prefs $ \ pref -> do
muser_email <- lift $ fetchUserEmail user_id
......
......@@ -287,6 +287,7 @@ executable SnowdriftEmailDaemon
, cmdargs
, data-default
, Diff
, directory
, esqueleto
, email-validate
, fast-logger
......@@ -356,6 +357,17 @@ executable sdm
, process
, semigroups
executable SnowdriftSendmail
if flag(dev)
ghc-options: -Wall
if flag(library-only)
Buildable: False
main-is: SnowdriftSendmail.hs
build-depends: base
, bytestring
, mime
test-suite test
type: exitcode-stdio-1.0
main-is: main.hs
......@@ -376,8 +388,12 @@ test-suite test
, resourcet
, monad-logger
, monad-control
, semigroups
, transformers
, bytestring
, directory
, filepath
, process
, text
, hspec
, network
......
This diff is collapsed.
......@@ -13,6 +13,7 @@ import Model.Utils
import qualified Data.Foldable as F
import Data.Maybe (fromJust)
import qualified Data.Text as T
import qualified Database.Persist
import Yesod.Default.Config (AppConfig (..), DefaultEnv (..))
import Yesod.Markdown
......@@ -115,18 +116,86 @@ notificationEventHandler AppConfig{..} (ECommentRethreaded _ Rethread{..}) = do
NotifRethreadedComment Nothing Nothing content
notificationEventHandler _ (ECommentClosed _ _) = return ()
notificationEventHandler _ (ENotificationSent _ _) = return ()
-- TODO: Send notification to anyone watching thread
notificationEventHandler _ (ETicketClaimed _) = return ()
notificationEventHandler _ (ETicketUnclaimed _ _) = return ()
notificationEventHandler _ (ENotificationSent _ _) = return ()
notificationEventHandler _ (EWikiEdit _ _ _) = return ()
notificationEventHandler _ (EWikiPage _ _ _) = return ()
notificationEventHandler _ (EBlogPost _ _) = return ()
notificationEventHandler _ (ENewPledge _ _) = return ()
notificationEventHandler _ (EUpdatedPledge _ _ _) = return ()
notificationEventHandler _ (EDeletedPledge _ _ _ _) = return ()
notificationEventHandler AppConfig{..} (EWikiEdit wiki_edit_id _ wiki_target) =
runSDB $ handleWatched appRoot (wikiTargetProject wiki_target)
(\ project_handle -> WikiEditR project_handle
(wikiTargetLanguage wiki_target)
(wikiTargetTarget wiki_target)
wiki_edit_id)
NotifWikiEdit
(\ route -> "Wiki page [edited](" <> route <> ")")
notificationEventHandler AppConfig{..} (EWikiPage _ wiki_page wiki_target) =
runSDB $ handleWatched appRoot (wikiPageProject wiki_page)
(\ project_handle -> WikiR project_handle
(wikiTargetLanguage wiki_target)
(wikiTargetTarget wiki_target))
NotifWikiPage
(\ route -> "New [wiki page](" <> route <> ")")
notificationEventHandler AppConfig{..} (EBlogPost _ blog_post) =
runSDB $ handleWatched appRoot (blogPostProject blog_post)
(\ project_handle -> BlogPostR project_handle $ blogPostHandle blog_post)
NotifBlogPost
(\ route -> "New [blog post](" <> route <> ")")
notificationEventHandler AppConfig{..} (ENewPledge _ shares_pledged) = runSDB $ do
users <- lift $ fetchUsersInDB [sharesPledgedUser shares_pledged]
let shares = sharesPledgedShares shares_pledged
forM_ users $ \ user_entity ->
handleWatched appRoot (sharesPledgedProject shares_pledged)
ProjectPatronsR NotifNewPledge
(\ route -> T.concat
[ userDisplayName user_entity
, " pledged ["
, T.pack $ show $ shares, " ", pluralShares shares
, "](", route, ")"
])
notificationEventHandler AppConfig{..} (EUpdatedPledge old_shares _ shares_pledged) = runSDB $ do
users <- lift $ fetchUsersInDB [sharesPledgedUser shares_pledged]
let new_shares = sharesPledgedShares shares_pledged
delta = abs $ old_shares - new_shares
forM_ users $ \ user_entity ->
handleWatched appRoot (sharesPledgedProject shares_pledged)
ProjectPatronsR NotifUpdatedPledge
(\ route -> T.concat
[ userDisplayName user_entity
, (if old_shares > new_shares then " dropped " else " added ")
<> (T.pack $ show $ delta), " ", pluralShares delta
, ", changing the total to [", T.pack $ show $ new_shares, " "
, pluralShares new_shares, "](", route, ")"
])
notificationEventHandler AppConfig{..} (EDeletedPledge _ user_id project_id _) = runSDB $ do
users <- lift $ fetchUsersInDB [user_id]
forM_ users $ \ user_entity ->
handleWatched appRoot project_id ProjectPatronsR NotifDeletedPledge
(\ route -> userDisplayName user_entity
<> " is no longer supporting the [project](" <> route <> ")")
pluralShares :: Integral i => i -> Text
pluralShares n = plural n "share" "shares"
handleWatched :: Text -> ProjectId -> (Text -> Route App) -> NotificationType
-> (Text -> Text) -> SDB ()
handleWatched appRoot project_id mkRoute notif_type mkMsg = do
projects <- lift $ fetchProjectDB project_id
forM_ projects $ \ (Entity _ project) -> do
route <- lift $ lift $ routeToText $ mkRoute $ projectHandle project
user_ids <- lift $ fetchUsersByNotifPrefDB notif_type (Just project_id)
forM_ user_ids $ \ user_id -> do
is_watching <- lift $ userIsWatchingProjectDB user_id project_id
when is_watching $
sendPreferredNotificationDB user_id notif_type
(Just project_id) Nothing
(Markdown $ mkMsg $ appRoot <> route)
-- | Handler in charge of inserting events (stripped down) into a separate table for each type.
eventInserterHandler :: SnowdriftEvent -> Daemon ()
......
{-# LANGUAGE LambdaCase #-}
module Main where
import qualified Codec.MIME.QuotedPrintable as QuotedPrintable
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as C
import System.Environment (getArgs)
import System.IO (stdin)
import Data.Monoid ((<>))
main :: IO ()
main = getArgs >>= \case
[] -> C.hGetContents stdin >>= C.putStrLn . decode
[file] -> C.hGetContents stdin >>= C.writeFile file . decode
args -> error $ "invalid arguments: " <> unwords args
decode :: ByteString -> ByteString
decode = C.pack . QuotedPrintable.decode . C.unpack
......@@ -13,6 +13,7 @@ module View.Project
import Import
import Data.Filter
import Data.Maybe (fromJust)
import Data.Order
import Model.Currency
import Model.Discussion
......@@ -28,8 +29,9 @@ import qualified Data.Text as T
import Data.Time.Clock
import Yesod.Markdown
renderProject :: Maybe ProjectId -> Project -> [Int64] -> Maybe (Entity Pledge) -> WidgetT App IO ()
renderProject maybe_project_id project pledges pledge = do
renderProject :: Maybe ProjectId -> Project -> Maybe UserId -> Bool -> [Int64]
-> Maybe (Entity Pledge) -> WidgetT App IO ()
renderProject maybe_project_id project mviewer_id is_watching pledges pledge = do
let share_value = projectShareValue project
users = fromIntegral $ length pledges
shares = sum pledges
......