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

SnowdriftEventHandler.hs 11.7 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 qualified Data.Foldable        as F
15
import           Data.Maybe           (fromJust)
16
import qualified Data.Text            as T
17
import qualified Database.Persist
18
import           Yesod.Default.Config (AppConfig (..), DefaultEnv (..))
19 20

-- Add more event handlers here.
21 22 23 24
snowdriftEventHandlers :: AppConfig DefaultEnv Extra
                       -> [SnowdriftEvent -> Daemon ()]
snowdriftEventHandlers conf =
    [ notificationEventHandler conf
25 26 27
    , eventInserterHandler
    ]

28
-- | Handler in charge of sending Notifications to interested parties.
29 30
notificationEventHandler :: AppConfig DefaultEnv Extra
                         -> SnowdriftEvent -> Daemon ()
31
-- Notify the comment's parent's poster that their comment has been replied to (per their preferences).
32
notificationEventHandler AppConfig{..} (ECommentPosted comment_id comment) = case commentParent comment of
33 34
    Nothing -> return ()
    Just parent_comment_id -> do
35 36 37
        parent_comment_route <- routeToText $ CommentDirectLinkR parent_comment_id
        reply_comment_route  <- routeToText $ CommentDirectLinkR comment_id
        runSDB $ do
38
            parent_user_id <- commentUser <$> lift (Database.Persist.getJust parent_comment_id)
39 40 41 42 43 44 45 46
            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.*"
                        ]
47

48
-- Notify all moderators of the project the comment was posted on.
49
-- Also notify the comment poster.
50
notificationEventHandler AppConfig{..} (ECommentPending comment_id comment) = runSDB $ do
51
    route_text <- lift (makeCommentRouteDB [LangEn] comment_id >>= lift . routeToText . fromJust)
52

53
    sendPreferredNotificationDB (commentUser comment) NotifUnapprovedComment Nothing Nothing $ mconcat
54
        [ "Your [comment]("
Nikita Karetnikov's avatar
Nikita Karetnikov committed
55
        , Markdown $ appRoot <> route_text
56 57 58 59 60 61
        , ") now awaits moderator approval."
        , "<br><br>"
        , "When a moderator acknowledges you as a legitimate user "
        , "(such as after you have posted a few meaningful comments), "
        , "you will become eligible for 'establishment'. "
        , "Established users can post without moderation."
62
        ]
63

64
    discussion <- lift $ fetchDiscussionDB [LangEn] $ commentDiscussion comment
65

66 67 68 69 70 71 72 73 74 75 76 77
    let projectComment (Entity project_id project) = do
            let content = mconcat
                  [ "An unapproved comment has been posted on a "
                  , Markdown (projectName project)
                  , " page. Please view it [here]("
                  , Markdown $ appRoot <> route_text
                  , ")."
                  ]

            mods <- lift $ fetchProjectModeratorsDB project_id
            F.forM_ mods $ \ user_id -> sendPreferredNotificationDB user_id NotifUnapprovedComment
                Nothing (Just comment_id) content
78

79
    case discussion of
80
        DiscussionOnProject project                     -> projectComment project
81
        DiscussionOnWikiPage (Entity _ WikiTarget{..})  -> projectComment =<< Entity wikiTargetProject <$> lift (getJust wikiTargetProject)
82
        DiscussionOnUser _                              -> error ""
83
        DiscussionOnBlogPost (Entity _ BlogPost{..})    -> projectComment =<< Entity blogPostProject <$> lift (getJust blogPostProject)
84

85
notificationEventHandler AppConfig{..} (ECommentApproved comment_id comment) = runSDB $ do
86
    route_text <- lift (makeCommentRouteDB [LangEn] comment_id >>= lift . routeToText . fromJust)
87
    sendPreferredNotificationDB (commentUser comment) NotifApprovedComment Nothing Nothing $ mconcat
88
        [ "Your [comment]("
Nikita Karetnikov's avatar
Nikita Karetnikov committed
89
        , Markdown $ appRoot <> route_text
90
        , ") has been approved."
91
        ]
92

93
-- Notify the rethreadee his/her comment has been rethreaded.
94
notificationEventHandler AppConfig{..} (ECommentRethreaded _ Rethread{..}) = do
95 96
    (comment, Just old_route, Just new_route) <- runDB $ (,,)
        <$> getJust rethreadOldComment
97 98
        <*> makeCommentRouteDB [LangEn] rethreadOldComment
        <*> makeCommentRouteDB [LangEn] rethreadNewComment
99 100 101 102 103 104

    rendered_old_route <- routeToText old_route
    rendered_new_route <- routeToText new_route

    let content = mconcat
          [ "One of your comments has been rethreaded from ~~"
105
          , Markdown $ appRoot <> rendered_old_route
106
          , "~~ to ["
107
          , Markdown $ appRoot <> rendered_new_route
108
          , "]("
109
          , Markdown $ appRoot <> rendered_new_route
110 111 112 113
          , "): "
          , Markdown rethreadReason
          ]

114 115
    runSDB $ sendPreferredNotificationDB (commentUser comment)
        NotifRethreadedComment Nothing Nothing content
116

117
notificationEventHandler _ (ECommentClosed _ _)     = return ()
118
notificationEventHandler _ (ENotificationSent _ _)  = return ()
119

120
-- TODO: Send notification to anyone watching thread
121 122 123
notificationEventHandler _ (ETicketClaimed _)       = return ()
notificationEventHandler _ (ETicketUnclaimed _ _)   = return ()

124 125
notificationEventHandler AppConfig{..} (EWikiEdit wiki_edit_id _ wiki_target) =
    runSDB $ handleWatched appRoot (wikiTargetProject wiki_target)
126
        (\ project_handle -> WikiEditR project_handle
127 128 129 130
                                      (wikiTargetLanguage wiki_target)
                                      (wikiTargetTarget wiki_target)
                                      wiki_edit_id)
        NotifWikiEdit
131
        (\ route -> "Wiki page [edited](" <> route <> ")")
132 133 134

notificationEventHandler AppConfig{..} (EWikiPage _ wiki_page wiki_target) =
    runSDB $ handleWatched appRoot (wikiPageProject wiki_page)
135
        (\ project_handle -> WikiR project_handle
136 137 138
                                  (wikiTargetLanguage wiki_target)
                                  (wikiTargetTarget wiki_target))
        NotifWikiPage
139
        (\ route -> "New [wiki page](" <> route <> ")")
140 141 142

notificationEventHandler AppConfig{..} (EBlogPost _ blog_post) =
    runSDB $ handleWatched appRoot (blogPostProject blog_post)
143
        (\ project_handle -> BlogPostR project_handle $ blogPostHandle blog_post)
144
        NotifBlogPost
145
        (\ route -> "New [blog post](" <> route <> ")")
146 147 148 149

notificationEventHandler AppConfig{..} (ENewPledge _ shares_pledged) = runSDB $ do
    users <- lift $ fetchUsersInDB [sharesPledgedUser shares_pledged]
    let shares = sharesPledgedShares shares_pledged
150
    forM_ users $ \ user_entity ->
151 152
        handleWatched appRoot (sharesPledgedProject shares_pledged)
            ProjectPatronsR NotifNewPledge
153
            (\ route -> T.concat
154 155
                 [ userDisplayName user_entity
                 , " pledged ["
Stephen Paul Weber's avatar
Stephen Paul Weber committed
156
                 , T.pack $ show shares, " ", pluralShares shares
157 158 159 160 161 162 163
                 , "](", 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
164
    forM_ users $ \ user_entity ->
165 166
        handleWatched appRoot (sharesPledgedProject shares_pledged)
            ProjectPatronsR NotifUpdatedPledge
167
            (\ route -> T.concat
168 169
                 [ userDisplayName user_entity
                 , (if old_shares > new_shares then " dropped " else " added ")
Stephen Paul Weber's avatar
Stephen Paul Weber committed
170
                <> T.pack (show delta), " ", pluralShares delta
171
                 , ", changing their total to [", T.pack $ show new_shares, " "
172 173 174 175 176
                 , pluralShares new_shares, "](", route, ")"
                 ])

notificationEventHandler AppConfig{..} (EDeletedPledge _ user_id project_id _) = runSDB $ do
    users <- lift $ fetchUsersInDB [user_id]
177
    forM_ users $ \ user_entity ->
178
        handleWatched appRoot project_id ProjectPatronsR NotifDeletedPledge
179
            (\ route -> userDisplayName user_entity
180 181 182 183 184 185 186 187
                   <> " 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
188
    projects <- lift $ fetchProjectDB project_id
189
    forM_ projects $ \ (Entity _ project) -> do
190 191
        route <- lift $ lift $ routeToText $ mkRoute $ projectHandle project
        user_ids <- lift $ fetchUsersByNotifPrefDB notif_type (Just project_id)
192
        forM_ user_ids $ \ user_id -> do
193 194
            is_watching <- lift $ userIsWatchingProjectDB user_id project_id
            when is_watching $
195
                sendPreferredNotificationDB user_id notif_type
196
                    (Just project_id) Nothing
197
                    (Markdown $ mkMsg $ appRoot <> route)
198 199 200 201

-- | 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).
202
eventInserterHandler (ECommentPosted comment_id Comment{..})                         = runDB (insert_ (EventCommentPosted (fromJust commentApprovedTs) comment_id))
203
eventInserterHandler (ECommentPending comment_id Comment{..})                        = runDB (insert_ (EventCommentPending commentCreatedTs comment_id))
204
eventInserterHandler (ECommentRethreaded rethread_id Rethread{..})                   = runDB (insert_ (EventCommentRethreaded rethreadTs rethread_id))
205
eventInserterHandler (ECommentClosed comment_closing_id CommentClosing{..})          = runDB (insert_ (EventCommentClosing commentClosingTs comment_closing_id))
206 207 208 209
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)))
210

211
eventInserterHandler (ETicketUnclaimed ticket_old_claiming_id TicketOldClaiming{..}) = runDB (insert_ (EventTicketUnclaimed ticketOldClaimingReleasedTs ticket_old_claiming_id))
212

213
eventInserterHandler (ENotificationSent notif_id Notification{..})                   = runDB (insert_ (EventNotificationSent notificationCreatedTs notif_id))
214 215
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))
216 217 218
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
219
eventInserterHandler (EBlogPost post_id BlogPost{..})                                = runDB (insert_ (EventBlogPost blogPostTs post_id))
220

221 222
-- We don't have a table for ECommentApproved, because ECommentPosted is fired at the same time.
eventInserterHandler (ECommentApproved _ _) = return ()