SnowdriftEventHandler.hs 5.89 KB
Newer Older
1 2 3 4 5 6
module SnowdriftEventHandler
    ( snowdriftEventHandlers
    ) where

import Import

7 8 9 10 11 12
import Handler.Utils
import Model.Comment
import Model.Discussion
import Model.Notification
import Model.Project
import Model.User
13

14
import           Data.Maybe           (fromJust)
15 16 17 18 19 20
import qualified Database.Persist
import           Yesod.Markdown

-- Add more event handlers here.
snowdriftEventHandlers :: [SnowdriftEvent -> Daemon ()]
snowdriftEventHandlers =
21
    [ notificationEventHandler
22 23 24
    , eventInserterHandler
    ]

25 26
-- | Handler in charge of sending Notifications to interested parties.
notificationEventHandler :: SnowdriftEvent -> Daemon ()
27
-- Notify the comment's parent's poster that their comment has been replied to (per their preferences).
28
notificationEventHandler (ECommentPosted comment_id comment) = case commentParent comment of
29 30 31 32
    Nothing -> return ()
    Just parent_comment_id -> do
        (parent_user_id, delivery) <- runDB $ do
            parent_user_id <- commentUser <$> Database.Persist.getJust parent_comment_id
33
            delivery <- fetchUserNotificationPrefDB parent_user_id NotifReply
34
            return (parent_user_id, delivery)
35
        -- Any non-Nothing delivery implies an internal Notification should be sent.
36
        when (isJust delivery) $ do
37 38
            parent_comment_route <- routeToText (CommentDirectLinkR parent_comment_id)
            reply_comment_route  <- routeToText (CommentDirectLinkR comment_id)
39 40 41 42 43 44 45 46

            let content = mconcat
                  [ "Someone replied to [your comment]("
                  , Markdown parent_comment_route
                  , ")! You can view the reply [here]("
                  , Markdown reply_comment_route
                  , ")."
                  , ""
47
                  , "*You can filter these notifications by adjusting the settings in your profile.*"
48
                  ]
49
            runSDB (sendNotificationDB_ NotifReply parent_user_id Nothing content)
50

51
-- Notify all moderators of the project the comment was posted on.
52
notificationEventHandler (ECommentPending comment_id comment) = do
53 54 55 56
    runSDB $ do
        (Entity project_id project) <- lift (fetchDiscussionDB (commentDiscussion comment)) >>= \case
            DiscussionOnProject  project                 -> return project
            DiscussionOnWikiPage (Entity _ WikiPage{..}) -> Entity wikiPageProject <$> getJust wikiPageProject
57

58 59 60 61 62 63 64 65 66 67 68 69 70 71
        route_text <- (lift . lift) (routeToText (CommentDirectLinkR comment_id)) -- TODO(mitchell): don't use direct link?
        let content = mconcat
              [ "An unapproved comment has been posted on a "
              , Markdown (projectName project)
              , " page. Please view it [here]("
              , Markdown 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)
72

73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97
-- Notify the rethreadee his/her comment has been rethreaded.
notificationEventHandler (ECommentRethreaded _ Rethread{..}) = do
    (comment, Just old_route, Just new_route) <- runDB $ (,,)
        <$> getJust rethreadOldComment
        <*> makeCommentRouteDB rethreadOldComment
        <*> makeCommentRouteDB rethreadNewComment

    rendered_old_route <- routeToText old_route
    rendered_new_route <- routeToText new_route

    -- TODO(aaron)
    let content = mconcat
          [ "One of your comments has been rethreaded from ~~"
          , Markdown rendered_old_route
          , "~~ to ["
          , Markdown rendered_new_route
          , "]("
          , Markdown rendered_new_route
          , "): "
          , Markdown rethreadReason
          ]

    runSDB (sendNotificationDB_ NotifRethreadedComment (commentUser comment) Nothing content)

notificationEventHandler (ENotificationSent _ _)  = return ()
98 99 100 101 102
notificationEventHandler (EWikiEdit _ _)          = return ()
notificationEventHandler (EWikiPage _ _)          = return ()
notificationEventHandler (ENewPledge _ _)         = return ()
notificationEventHandler (EUpdatedPledge _ _ _)   = return ()
notificationEventHandler (EDeletedPledge _ _ _ _) = return ()
103 104 105 106

-- | Handler in charge of inserting events (stripped down) into a separate table for each type.
eventInserterHandler :: SnowdriftEvent -> Daemon ()
-- If an unapproved comment is sent as an ECommentPosted event, bad things will happen (fromJust).
107
eventInserterHandler (ECommentPosted comment_id Comment{..})                         = runDB (insert_ (EventCommentPosted (fromJust commentApprovedTs) comment_id))
108
eventInserterHandler (ECommentPending comment_id Comment{..})                        = runDB (insert_ (EventCommentPending commentCreatedTs comment_id))
109
eventInserterHandler (ECommentRethreaded rethread_id Rethread{..})                   = runDB (insert_ (EventCommentRethreaded rethreadTs rethread_id))
110
eventInserterHandler (ENotificationSent notif_id Notification{..})                   = runDB (insert_ (EventNotificationSent notificationCreatedTs notif_id))
111 112 113 114 115
eventInserterHandler (EWikiPage wiki_page_id WikiPage{..})                           = runDB (insert_ (EventWikiPage wikiPageCreatedTs wiki_page_id))
eventInserterHandler (EWikiEdit wiki_edit_id WikiEdit{..})                           = runDB (insert_ (EventWikiEdit wikiEditTs wiki_edit_id))
eventInserterHandler (ENewPledge shares_pledged_id SharesPledged{..})                = runDB (insert_ (EventNewPledge sharesPledgedTs shares_pledged_id))
eventInserterHandler (EUpdatedPledge old_shares shares_pledged_id SharesPledged{..}) = runDB (insert_ (EventUpdatedPledge sharesPledgedTs old_shares shares_pledged_id))
eventInserterHandler (EDeletedPledge ts user_id project_id shares)                   = runDB (insert_ (EventDeletedPledge ts user_id project_id shares))