Commit e6fb456a authored by Mitchell Rosen's avatar Mitchell Rosen

send 'unapproved comment' msg to project moderators. some event refactoring

parent 5ba0988f
......@@ -9,9 +9,9 @@ module Application
import Import
import Settings
import SnowdriftEventHandler
import Version
import Blaze.ByteString.Builder (toLazyByteString)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, newTChanIO, tryReadTChan)
import Control.Monad.Logger (runLoggingT, runStderrLoggingT)
......@@ -20,10 +20,7 @@ import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Data.Default (def)
import qualified Data.List as L
import Data.Maybe (fromJust)
import Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.IO as T
import qualified Database.Persist
import Database.Persist.Postgresql (pgConnStr, withPostgresqlConn)
......@@ -37,12 +34,10 @@ import System.Directory
import System.Environment (lookupEnv)
import System.Log.FastLogger (newStdoutLoggerSet, defaultBufSize, flushLogStr)
import System.Posix.Env.ByteString
import Yesod (renderRoute)
import Yesod.Core.Types (loggerSet, Logger (Logger))
import Yesod.Default.Config
import Yesod.Default.Handlers
import Yesod.Default.Main
import Yesod.Markdown
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
......@@ -71,9 +66,6 @@ import Handler.Widget
import Handler.Wiki
import Handler.Wiki.Comment
import Model.Message
import Model.User
import Widgets.Navbar
runSql :: MonadSqlPersist m => Text -> m ()
......@@ -156,10 +148,7 @@ makeFoundation conf = do
dbconf
logger
event_chan
-- Add more event handlers here.
[ messageEventHandler
, eventInserterHandler
]
snowdriftEventHandlers
-- Perform database migration using our application's logging settings.
case appEnv conf of
......@@ -354,50 +343,3 @@ forkEventHandler app@App{..} = void . forkIO . forever $ do
Just event -> do
mapM_ (runDaemon app) (appEventHandlers <*> [event])
handleNEvents (n-1)
-- | Handler in charge of sending Messages to interested parties.
messageEventHandler :: SnowdriftEvent -> Daemon ()
messageEventHandler (ECommentPosted comment_id comment) = case commentParent comment of
Nothing -> return ()
Just parent_comment_id -> do
(parent_user_id, delivery) <- runDB $ do
parent_user_id <- commentUser <$> Database.Persist.getJust parent_comment_id
delivery <- fetchUserMessagePrefDB parent_user_id MessageReply
return (parent_user_id, delivery)
-- Any non-Nothing delivery implies an internal Message should be sent.
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
, ")."
, ""
, "*You can filter these messages by adjusting the settings in your profile.*"
]
void $ runSDB (sendNotificationMessageDB MessageReply parent_user_id content)
-- TODO(mitchell): send messages on other events, per preferences
messageEventHandler _ = return ()
-- | 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))
eventInserterHandler (EMessageSent message_id Message{..}) = runDB (insert_ (EventMessageSent messageCreatedTs message_id))
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)
......@@ -938,9 +938,9 @@ makeCommentWidgetMod CommentMods{..} get_max_depth show_actions form_under_root_
-- Experimental - /c/#CommentId
getCommentDirectLinkR :: CommentId -> Handler Html
getCommentDirectLinkR comment_id = runDB (fetchCommentPageEntityDB comment_id) >>= \case
getCommentDirectLinkR comment_id = runDB (fetchCommentWikiPageDB comment_id) >>= \case
-- comment not on a wiki page? right now, there's nowhere else to check
-- TODO: fixme once discussions are expanded
-- TODO(mitchell): does this require constant attention?
Nothing -> notFound
Just (Entity _ page) -> do
project <- runYDB $ get404 (wikiPageProject page)
......
......@@ -34,7 +34,7 @@ module Model.Comment
, fetchCommentDestinationDB
, fetchCommentFlaggingDB
, fetchCommentsDescendantsDB
, fetchCommentPageEntityDB
, fetchCommentWikiPageDB
, fetchCommentRethreadDB
, fetchCommentTagsDB
, filterCommentsDB
......@@ -320,10 +320,10 @@ unsafeFetchCommentPageIdDB = fmap entityKey . unsafeFetchCommentPageEntityDB
-- | Fails if the given Comment is not on a WikiPage, but some other Discussion.
unsafeFetchCommentPageEntityDB :: CommentId -> DB (Entity WikiPage)
unsafeFetchCommentPageEntityDB = fmap fromJust . fetchCommentPageEntityDB
unsafeFetchCommentPageEntityDB = fmap fromJust . fetchCommentWikiPageDB
fetchCommentPageEntityDB :: CommentId -> DB (Maybe (Entity WikiPage))
fetchCommentPageEntityDB comment_id = fmap listToMaybe $
fetchCommentWikiPageDB :: CommentId -> DB (Maybe (Entity WikiPage))
fetchCommentWikiPageDB comment_id = fmap listToMaybe $
select $
from $ \(c `InnerJoin` p) -> do
on_ (c ^. CommentDiscussion ==. p ^. WikiPageDiscussion)
......
module Model.Discussion
( createDiscussionDB
, fetchDiscussionProjectDB
, fetchDiscussionWikiPage
, fetchDiscussionWikiPagesInDB
) where
import Import
import Control.Monad.Trans.Maybe
-- | Given a list of DiscussionId, fetch the discussions which are WikiPages.
fetchDiscussionWikiPagesInDB :: [DiscussionId] -> DB [Entity WikiPage]
fetchDiscussionWikiPagesInDB discussion_ids =
......@@ -13,5 +17,26 @@ fetchDiscussionWikiPagesInDB discussion_ids =
where_ (wp ^. WikiPageDiscussion `in_` valList discussion_ids)
return wp
-- | Fetch the Project this Discussion is associated with (if any).
-- TODO(mitchell): Does this require constant attention, as we expand
-- discussions?
fetchDiscussionProjectDB :: DiscussionId -> DB (Maybe ProjectId)
fetchDiscussionProjectDB discussion_id = runMaybeT $
-- From a list of possible ways to find a ProjectId from a DiscussionId, find the Project (maybe).
foldr (mplus . f) mzero
-- add more functions here as necessary
[(fetchDiscussionWikiPage, wikiPageProject)]
where
-- f :: (DiscussionId -> DB (Maybe (Entity a)), a -> ProjectId) -> MaybeT DB (Entity Project)
f (action, project_id_getter) = project_id_getter . entityVal <$> MaybeT (action discussion_id)
-- | Fetch the WikiPage this Discussion is on with (if any).
fetchDiscussionWikiPage :: DiscussionId -> DB (Maybe (Entity WikiPage))
fetchDiscussionWikiPage discussion_id = fmap listToMaybe $
select $
from $ \wp -> do
where_ (wp ^. WikiPageDiscussion ==. val discussion_id)
return wp
createDiscussionDB :: DB DiscussionId
createDiscussionDB = insert (Discussion 0)
......@@ -7,6 +7,7 @@ module Model.Project
, fetchProjectCommentsPostedOnWikiPagesBeforeDB
, fetchProjectDeletedPledgesBeforeDB
, fetchProjectNewPledgesBeforeDB
, fetchProjectModeratorsDB
, fetchProjectTeamMembersDB
, fetchProjectUpdatedPledgesBeforeDB
, fetchProjectVolunteerApplicationsDB
......@@ -283,6 +284,9 @@ fetchProjectDeletedPledgesBeforeDB project_id before = fmap (map entityVal) $
fetchProjectTeamMembersDB :: ProjectId -> DB [UserId]
fetchProjectTeamMembersDB = fetchProjectRoleDB TeamMember
fetchProjectModeratorsDB :: ProjectId -> DB [UserId]
fetchProjectModeratorsDB = fetchProjectRoleDB Moderator
-- | Abstract fetching Project Admins, TeamMembers, etc. Not exported.
fetchProjectRoleDB :: Role -> ProjectId -> DB [UserId]
fetchProjectRoleDB role project_id = fmap (map unValue) $
......@@ -292,7 +296,7 @@ fetchProjectRoleDB role project_id = fmap (map unValue) $
pur ^. ProjectUserRoleProject ==. val project_id &&.
pur ^. ProjectUserRoleRole ==. val role
return (pur ^. ProjectUserRoleUser)
--
-- | Fetch all Project VolunteerApplications.
fetchProjectVolunteerApplicationsDB :: ProjectId -> DB [Entity VolunteerApplication]
fetchProjectVolunteerApplicationsDB project_id =
......
......@@ -58,6 +58,7 @@ library
Settings
Settings.StaticFiles
Settings.Development
SnowdriftEventHandler
Handler.BuildFeed
Handler.Contact
Handler.Home
......
module SnowdriftEventHandler
( snowdriftEventHandlers
) where
import Import
import Model.Discussion
import Model.Message
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 =
[ messageEventHandler
, eventInserterHandler
]
-- | Handler in charge of sending Messages to interested parties.
messageEventHandler :: SnowdriftEvent -> Daemon ()
-- Notify the comment's parent's poster that their comment has been replied to (per their preferences).
messageEventHandler (ECommentPosted comment_id comment) = case commentParent comment of
Nothing -> return ()
Just parent_comment_id -> do
(parent_user_id, delivery) <- runDB $ do
parent_user_id <- commentUser <$> Database.Persist.getJust parent_comment_id
delivery <- fetchUserMessagePrefDB parent_user_id MessageReply
return (parent_user_id, delivery)
-- Any non-Nothing delivery implies an internal Message should be sent.
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
, ")."
, ""
, "*You can filter these messages by adjusting the settings in your profile.*"
]
void $ runSDB (sendNotificationMessageDB MessageReply parent_user_id content)
-- Notify all moderators of the project the comment was posted on.
messageEventHandler (ECommentPending comment_id comment) = do
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) >>=
mapM_ (\user_id -> sendNotificationMessageDB MessageDirect user_id content)
-- | 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))
eventInserterHandler (EMessageSent message_id Message{..}) = runDB (insert_ (EventMessageSent messageCreatedTs message_id))
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)
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment