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

import Import

7 8 9 10 11
import Model.Comment
import Model.Discussion
import Model.Notification
import Model.Project
import Model.User
12
import Model.Utils
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
    runSDB $ do
54 55 56 57 58 59 60 61 62 63
        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?
                let content = mconcat
                      [ "An unapproved comment has been posted on a "
                      , Markdown (projectName project)
                      , " page. Please view it [here]("
                      , Markdown route_text
                      , ")."
                      ]
64

65 66 67 68 69 70 71 72 73 74 75
                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)

        case discussion of
            DiscussionOnProject  project                 -> projectComment project
            DiscussionOnWikiPage (Entity _ WikiPage{..}) -> projectComment =<< Entity wikiPageProject <$> getJust wikiPageProject
            DiscussionOnUser _ -> error ""
            -- TODO DiscussionOnUser user -> userComment user
76

77 78 79 80 81 82
{-
    userComment (Entity user_id user) = do
        route_text <- (lift . lift) (routeToText (CommentDirectLinkR comment_id)) -- TODO(mitchell): don't use direct link?
        let content = "An unapproved comment has been posted on your user discussion page.  Please view it [here](" <> Markdown route_text <> ")."
        sendNotificationDB NotifUnapprovedComment user_id Nothing content >>= insert_ . UnapprovedCommentNotification comment_id
-}
83

84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106
-- 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

    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)

107 108
notificationEventHandler (ECommentClosed _ _)     = return ()

David L. L. Thomas's avatar
David L. L. Thomas committed
109
-- TODO: Send notification to anyone watching thread
110
notificationEventHandler (ETicketClaimed _)     = return ()
David L. L. Thomas's avatar
David L. L. Thomas committed
111 112
notificationEventHandler (ETicketUnclaimed _ _)     = return ()

113
notificationEventHandler (ENotificationSent _ _)  = return ()
114 115
notificationEventHandler (EWikiEdit _ _)          = return ()
notificationEventHandler (EWikiPage _ _)          = return ()
David L. L. Thomas's avatar
David L. L. Thomas committed
116
notificationEventHandler (EBlogPost _ _)          = return ()
117 118 119
notificationEventHandler (ENewPledge _ _)         = return ()
notificationEventHandler (EUpdatedPledge _ _ _)   = return ()
notificationEventHandler (EDeletedPledge _ _ _ _) = return ()
120 121 122 123

-- | 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).
124
eventInserterHandler (ECommentPosted comment_id Comment{..})                         = runDB (insert_ (EventCommentPosted (fromJust commentApprovedTs) comment_id))
125
eventInserterHandler (ECommentPending comment_id Comment{..})                        = runDB (insert_ (EventCommentPending commentCreatedTs comment_id))
126
eventInserterHandler (ECommentRethreaded rethread_id Rethread{..})                   = runDB (insert_ (EventCommentRethreaded rethreadTs rethread_id))
127
eventInserterHandler (ECommentClosed comment_closing_id CommentClosing{..})          = runDB (insert_ (EventCommentClosing commentClosingTs comment_closing_id))
128 129 130 131
eventInserterHandler (ETicketClaimed (Left (ticket_claiming_id, TicketClaiming{..})))
                        = runDB (insert_ (EventTicketClaimed ticketClaimingTs (Just ticket_claiming_id) Nothing))
eventInserterHandler (ETicketClaimed (Right (ticket_old_claiming_id, TicketOldClaiming{..})))
                        = runDB (insert_ (EventTicketClaimed ticketOldClaimingClaimTs Nothing (Just ticket_old_claiming_id)))
David L. L. Thomas's avatar
David L. L. Thomas committed
132

133
eventInserterHandler (ETicketUnclaimed ticket_old_claiming_id TicketOldClaiming{..}) = runDB (insert_ (EventTicketUnclaimed ticketOldClaimingReleasedTs ticket_old_claiming_id))
David L. L. Thomas's avatar
David L. L. Thomas committed
134

135
eventInserterHandler (ENotificationSent notif_id Notification{..})                   = runDB (insert_ (EventNotificationSent notificationCreatedTs notif_id))
136 137 138 139 140
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))
David L. L. Thomas's avatar
David L. L. Thomas committed
141
eventInserterHandler (EBlogPost post_id BlogPost{..})                                = runDB (insert_ (EventBlogPost blogPostTs post_id))