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

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

import Import

import           Model.Discussion
8
import           Model.Notification
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
import           Model.Project
import           Model.User

import           Blaze.ByteString.Builder (toLazyByteString)
import           Control.Monad.Reader
import           Data.Maybe               (fromJust)
import qualified Data.Text.Lazy           as TL
import qualified Data.Text.Lazy.Encoding  as TLE
import qualified Database.Persist
import           Yesod                    (renderRoute)
import           Yesod.Markdown

-- Add more event handlers here.
snowdriftEventHandlers :: [SnowdriftEvent -> Daemon ()]
snowdriftEventHandlers =
24
    [ notificationEventHandler
25 26 27
    , eventInserterHandler
    ]

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

            let content = mconcat
                  [ "Someone replied to [your comment]("
                  , Markdown parent_comment_route
                  , ")! You can view the reply [here]("
                  , Markdown reply_comment_route
                  , ")."
                  , ""
51
                  , "*You can filter these notifications by adjusting the settings in your profile.*"
52
                  ]
53
            runSDB (sendNotificationDB_ NotifReply parent_user_id Nothing content)
54
-- Notify all moderators of the project the comment was posted on.
55
notificationEventHandler (ECommentPending comment_id comment) = do
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70
    app <- ask
    runSDB $ lift (fetchDiscussionProjectDB (commentDiscussion comment)) >>= \case
        Nothing -> return () -- Comment wasn't on a project, somehow? I guess do nothing.
        Just project_id -> do
            project <- getJust project_id

            let content = mconcat
                  [ "An unapproved comment has been posted on a "
                  , Markdown (projectName project)
                  , " page. Please view it [here]("
                  , Markdown (renderRoute' (CommentDirectLinkR comment_id) app)
                  , ")."
                  ]

            lift (fetchProjectModeratorsDB project_id) >>=
71 72 73 74 75 76 77 78 79 80
                -- 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)
notificationEventHandler (ENotificationSent _ _)       = return ()
notificationEventHandler (EWikiEdit _ _)          = return ()
notificationEventHandler (EWikiPage _ _)          = return ()
notificationEventHandler (ENewPledge _ _)         = return ()
notificationEventHandler (EUpdatedPledge _ _ _)   = return ()
notificationEventHandler (EDeletedPledge _ _ _ _) = return ()
81 82 83 84 85 86

-- | 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).
eventInserterHandler (ECommentPosted comment_id Comment{..})                         = runDB (insert_ (EventCommentPosted (fromJust commentModeratedTs) comment_id))
eventInserterHandler (ECommentPending comment_id Comment{..})                        = runDB (insert_ (EventCommentPending commentCreatedTs comment_id))
87
eventInserterHandler (ENotificationSent notif_id Notification{..})                   = runDB (insert_ (EventNotificationSent notificationCreatedTs notif_id))
88 89 90 91 92 93 94 95 96 97 98 99
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))

renderRoute' :: Route App -> App -> Text
renderRoute' route app =
    let (path_pieces, query_params) = renderRoute route
    -- converting a lazy ByteString to a strict Text... ridiculous!
    -- why does joinPath return a ByteString??
    in TL.toStrict $ TLE.decodeUtf8 $ toLazyByteString (joinPath app "" path_pieces query_params)