Commit f5448a1e authored by Mitchell Rosen's avatar Mitchell Rosen

rethread notifications and project feed events

parent ab6967d3
......@@ -481,74 +481,52 @@ postRethreadComment user_id comment_id comment = do
-- FIXME(mitchell,david): We shouldn't have to enumerate the routes like this.
-- Luckily robust rethreading is not priority.
(new_parent_id, new_discussion_id) <- case parseRoute (url, []) of
Just (WikiCommentR new_project_handle new_target new_parent_id) -> do
(new_route, mnew_parent_id, new_discussion_id) <- case parseRoute (url, []) of
Just (new_route@(WikiCommentR new_project_handle new_target new_parent_id)) -> do
new_discussion_id <-
maybe notfound (wikiPageDiscussion . entityVal) <$>
runDB (fetchProjectWikiPageByNameDB new_project_handle new_target)
return (Just new_parent_id, new_discussion_id)
Just (WikiDiscussionR new_project_handle new_target) -> do
return (new_route, Just new_parent_id, new_discussion_id)
Just (new_route@(WikiDiscussionR new_project_handle new_target)) -> do
new_discussion_id <-
maybe notfound (wikiPageDiscussion . entityVal) <$>
runDB (fetchProjectWikiPageByNameDB new_project_handle new_target)
return (Nothing, new_discussion_id)
Just (ProjectCommentR new_project_handle new_parent_id) -> do
return (new_route, Nothing, new_discussion_id)
Just (new_route@(ProjectCommentR new_project_handle new_parent_id)) -> do
new_discussion_id <-
maybe notfound (projectDiscussion . entityVal) <$>
runDB (getBy (UniqueProjectHandle new_project_handle))
return (Just new_parent_id, new_discussion_id)
Just (ProjectDiscussionR new_project_handle) -> do
return (new_route, Just new_parent_id, new_discussion_id)
Just (new_route@(ProjectDiscussionR new_project_handle)) -> do
new_discussion_id <-
maybe notfound (projectDiscussion . entityVal) <$>
runDB (getBy (UniqueProjectHandle new_project_handle))
return (Nothing, new_discussion_id)
return (new_route, Nothing, new_discussion_id)
Nothing -> error "failed to parse URL"
_ -> notfound
let old_parent_id = commentParent comment
when (new_parent_id == old_parent_id && new_discussion_id == commentDiscussion comment) $
error "trying to move comment to its current location"
let mold_parent_id = commentParent comment
when (mnew_parent_id == mold_parent_id && new_discussion_id == commentDiscussion comment) $ do
alertDanger "trying to move comment to its current location"
getCommentDirectLinkR comment_id
new_parent_depth <- maybe (return $ -1) fetchCommentDepth404DB new_parent_id
old_parent_depth <- maybe (return $ -1) fetchCommentDepth404DB old_parent_id
let depth_offset = old_parent_depth - new_parent_depth
new_parent_depth <- maybe (return (-1)) fetchCommentDepth404DB mnew_parent_id
old_parent_depth <- maybe (return (-1)) fetchCommentDepth404DB mold_parent_id
lookupPostMode >>= \case
Just PostMode -> do
now <- liftIO getCurrentTime
runDB $ do
descendants <- fetchCommentAllDescendantsDB comment_id
rethread_id <- insert (Rethread now user_id comment_id reason)
let comments = comment_id : descendants
new_comment_ids <- rethreadCommentsDB rethread_id depth_offset new_parent_id new_discussion_id comments
delete $
from $ \ca ->
where_ $ ca ^. CommentAncestorComment `in_` valList comments
forM_ new_comment_ids $ \ new_comment_id -> do
insertSelect $
from $ \(c `InnerJoin` ca) -> do
on_ (c ^. CommentParent ==. just (ca ^. CommentAncestorComment))
where_ (c ^. CommentId ==. val new_comment_id)
return (CommentAncestor <# val new_comment_id <&> (ca ^. CommentAncestorAncestor))
[Value maybe_new_parent_id] <-
select $
from $ \c -> do
where_ (c ^. CommentId ==. val new_comment_id)
return (c ^. CommentParent)
maybe (return ()) (insert_ . CommentAncestor new_comment_id) maybe_new_parent_id
when (new_discussion_id /= commentDiscussion comment) $
update $ \c -> do
set c [ CommentDiscussion =. val new_discussion_id ]
where_ (c ^. CommentId `in_` valList descendants)
runSDB $
rethreadCommentDB
mnew_parent_id
new_discussion_id
comment_id
user_id
reason
(old_parent_depth - new_parent_depth)
new_route_text <- getUrlRender <*> pure new_route
alertSuccess ("comment rethreaded to " <> new_route_text)
redirect new_parent_url
_ -> error "no preview for rethreads yet" -- TODO(david)
......@@ -629,14 +607,8 @@ postCommentCreateTag comment_id = do
--------------------------------------------------------------------------------
-- /
getCommentDirectLinkR :: CommentId -> Handler Html
getCommentDirectLinkR comment_id = runDB (fetchCommentWikiPageDB comment_id) >>= \case
-- comment not on a wiki page? right now, there's nowhere else to check
-- TODO(mitchell): does this require constant attention?
Nothing -> notFound
Just (Entity _ page) -> do
project <- runYDB (get404 (wikiPageProject page))
redirect (WikiCommentR (projectHandle project) (wikiPageTarget page) comment_id)
getCommentDirectLinkR :: CommentId -> Handler ()
getCommentDirectLinkR comment_id = runDB (makeCommentRouteDB comment_id) >>= maybe notFound redirect
deleteCommentDirectLinkR :: CommentId -> Handler ()
deleteCommentDirectLinkR comment_id = do
......
......@@ -33,6 +33,7 @@ import Widgets.Preview
import Widgets.Time
import Data.Default (def)
import qualified Data.Foldable as F
import Data.List (sortBy)
import qualified Data.Map as M
import Data.Maybe (maybeToList)
......@@ -802,52 +803,45 @@ getEditProjectR project_handle = do
-- statically guarantees that.
getProjectFeedR :: Text -> Handler Html
getProjectFeedR project_handle = do
let lim = 26 -- limit n from each table, then take (n-1)
let lim = 26 -- limit 'lim' from each table, then take 'lim - 1'
muser <- maybeAuth
let muser_id = entityKey <$> muser
before <- lookupGetUTCTimeDefaultNow "before"
(project, comment_entities, wiki_pages, wiki_edit_entities,
new_pledges, updated_pledges, deleted_pledges,
discussion_wiki_page_map, wiki_page_map, user_map,
(project, comments, rethreads, wiki_pages, wiki_edits, new_pledges,
updated_pledges, deleted_pledges, discussion_map, wiki_page_map, user_map,
earlier_closures_map, closure_map, ticket_map, flag_map) <- runYDB $ do
Entity project_id project <- getBy404 (UniqueProjectHandle project_handle)
project_comments <- fetchProjectCommentsBeforeDB project_id muser_id before lim
wiki_page_comments <- fetchProjectWikiPageCommentsBeforeDB project_id muser_id before lim
wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim
wiki_edit_entities <- fetchProjectWikiEditsBeforeDB project_id before lim
new_pledges <- fetchProjectNewPledgesBeforeDB project_id before lim
updated_pledges <- fetchProjectUpdatedPledgesBeforeDB project_id before lim
deleted_pledges <- fetchProjectDeletedPledgesBeforeDB project_id before lim
comments <- fetchProjectCommentsIncludingRethreadedBeforeDB project_id muser_id before lim
rethreads <- fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim
wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim
wiki_edits <- fetchProjectWikiEditsBeforeDB project_id before lim
new_pledges <- fetchProjectNewPledgesBeforeDB project_id before lim
updated_pledges <- fetchProjectUpdatedPledgesBeforeDB project_id before lim
deleted_pledges <- fetchProjectDeletedPledgesBeforeDB project_id before lim
-- Suplementary maps for displaying the data. If something above requires extra
-- data to display the project feed row, it MUST be used to fetch the data below!
-- The Maybes from Data.Map.lookup are unsafely STRIPPED in the views!
let comment_entities = project_comments <> wiki_page_comments
comment_ids = map entityKey comment_entities
comments = map entityVal comment_entities
wiki_edits = map entityVal wiki_edit_entities
shares_pledged = map entityVal (new_pledges <> (map snd updated_pledges))
-- All users: Comment posters, WikiPage creators, WikiEdit makers,
-- and Pledgers (new, updated, and deleted).
let (comment_ids, comment_users) = F.foldMap (\c -> ([entityKey c], [commentUser (entityVal c)])) comments
(wiki_edit_users, wiki_edit_pages) = F.foldMap (\(Entity _ e) -> ([wikiEditUser e], [wikiEditPage e])) wiki_edits
shares_pledged = map entityVal (new_pledges <> (map snd updated_pledges))
-- All users: comment posters, wiki page creators, etc.
user_ids = S.toList $
S.fromList (map commentUser comments) <>
S.fromList (map wikiEditUser wiki_edits) <>
S.fromList comment_users <>
S.fromList (map (rethreadModerator . entityVal) rethreads) <>
S.fromList wiki_edit_users <>
S.fromList (map sharesPledgedUser shares_pledged) <>
S.fromList (map eventDeletedPledgeUser deleted_pledges)
-- WikiPages that can be keyed by a Comment's DiscussionId (i.e. the Comment *is* on a WikiPage)
discussion_wiki_page_map <- M.fromList . map (\e@(Entity _ WikiPage{..}) -> (wikiPageDiscussion, e)) <$>
fetchDiscussionWikiPagesInDB (map commentDiscussion comments)
discussion_map <- fetchProjectDiscussionsDB project_id >>= fetchDiscussionsDB
-- WikiPages keyed by their own IDs (contained in a WikiEdit)
wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB (map wikiEditPage wiki_edits)
wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB wiki_edit_pages
user_map <- entitiesMap <$> fetchUsersInDB user_ids
......@@ -856,21 +850,21 @@ getProjectFeedR project_handle = do
ticket_map <- makeTicketMapDB comment_ids
flag_map <- makeFlagMapDB comment_ids
return (project, comments, rethreads, wiki_pages, wiki_edits,
new_pledges, updated_pledges, deleted_pledges, discussion_map,
wiki_page_map, user_map, earlier_closures_map, closure_map,
ticket_map, flag_map)
return (project, comment_entities, wiki_pages, wiki_edit_entities,
new_pledges, updated_pledges, deleted_pledges,
discussion_wiki_page_map, wiki_page_map, user_map,
earlier_closures_map, closure_map, ticket_map, flag_map)
action_permissions_map <- makeProjectCommentActionPermissionsMap muser project_handle comment_entities
action_permissions_map <- makeProjectCommentActionPermissionsMap muser project_handle comments
let all_unsorted_events = mconcat
[ map (onEntity ECommentPosted) comment_entities
, map (onEntity EWikiPage) wiki_pages
, map (onEntity EWikiEdit) wiki_edit_entities
, map (onEntity ENewPledge) new_pledges
, map eup2se updated_pledges
, map edp2se deleted_pledges
[ map (onEntity ECommentPosted) comments
, map (onEntity ECommentRethreaded) rethreads
, map (onEntity EWikiPage) wiki_pages
, map (onEntity EWikiEdit) wiki_edits
, map (onEntity ENewPledge) new_pledges
, map eup2se updated_pledges
, map edp2se deleted_pledges
]
(events, more_events) = splitAt (lim-1) (sortBy snowdriftEventNewestToOldest all_unsorted_events)
......@@ -887,11 +881,11 @@ getProjectFeedR project_handle = do
$(widgetFile "project_feed")
toWidget $(cassiusFile "templates/comment.cassius")
where
-- "event updated pledge to snowdrift event". Makes above code cleaner.
-- "event updated pledge to snowdrift event"
eup2se :: (Int64, Entity SharesPledged) -> SnowdriftEvent
eup2se (old_shares, Entity shares_pledged_id shares_pledged) = EUpdatedPledge old_shares shares_pledged_id shares_pledged
-- "event deleted pledge to snowdrift event". Makes above code cleaner.
-- "event deleted pledge to snowdrift event"
edp2se :: EventDeletedPledge -> SnowdriftEvent
edp2se (EventDeletedPledge a b c d) = EDeletedPledge a b c d
......
......@@ -2,7 +2,12 @@ module Handler.Utils where
import Import
import qualified Data.Text as T
import Blaze.ByteString.Builder (Builder, toLazyByteString)
import Control.Monad.Reader (MonadReader, ask)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Yesod (renderRoute)
-- | Possible values for "mode" post param.
data PostMode
......@@ -23,3 +28,12 @@ lookupGetUTCTimeDefaultNow name = lookupGetParam name >>= \case
Just value -> case reads (T.unpack value) of
[(time,"")] -> return time
_ -> liftIO getCurrentTime
routeToText :: MonadReader App m => Route App -> m Text
routeToText route = do
app <- ask
let (path_pieces, query_params) = renderRoute route
return (b2t (joinPath app "" path_pieces query_params))
where
b2t :: Builder -> Text
b2t = TL.toStrict . TLE.decodeUtf8 . toLazyByteString
......@@ -238,6 +238,10 @@ getByErr message = runYDB . fmap fromJustError . getBy
lookupErr :: Ord k => String -> k -> Map k a -> a
lookupErr = M.findWithDefault . error
fromJustErr :: String -> Maybe a -> a
fromJustErr _ (Just x) = x
fromJustErr msg _ = error msg
class WrappedValues a where
type Unwrapped a
unwrapValues :: a -> Unwrapped a
......
This diff is collapsed.
......@@ -77,22 +77,28 @@ exprCommentRootPostedBy user_id c = ((isNothing (c ^. CommentParent)) &&. c ^. C
-- If logged in, show all approved (hiding flagged), plus own comments (unapproved + flagged).
-- If not logged in, show all approved (hiding flagged).
-- No matter what, hide rethreaded comments (they've essentially been replaced).
-- TODO(mitchell, david): rethink this function with regards to comment visibility
exprCommentProjectPermissionFilter :: Maybe UserId -> SqlExpr (Value ProjectId) -> ExprCommentCond
exprCommentProjectPermissionFilter muser_id project_id c = exprCommentNotRethreaded c &&. permissionFilter &&. isVisible
exprCommentProjectPermissionFilter muser_id project_id c =
exprCommentNotRethreaded c &&. exprCommentProjectPermissionFilterIncludingRethreaded muser_id project_id c
-- | A "special case" of the above (almost universal) permission filter, for Project feeds: we *do*
-- want to display rethreaded Comments in this case, because otherwise, the original "comment posted"
-- feed events would vanish.
exprCommentProjectPermissionFilterIncludingRethreaded :: Maybe UserId -> SqlExpr (Value ProjectId) -> ExprCommentCond
exprCommentProjectPermissionFilterIncludingRethreaded muser_id project_id c = isVisible &&. permissionFilter
where
permissionFilter :: SqlExpr (Value Bool)
permissionFilter = case muser_id of
Just user_id -> approvedAndNotFlagged ||. exprCommentPostedBy user_id c ||. exprUserIsModerator user_id project_id
Nothing -> approvedAndNotFlagged
-- isVisible when comment is public (VisPublic), or the viewer is
-- a project team member, or the viewer posted the topic initially
isVisible :: SqlExpr (Value Bool)
isVisible = seq (appendFile "testlog" $ "isVisible for " ++ show muser_id) $ case muser_id of
-- TODO(mitchell, david): this is wrong, but good enough for now
isVisible = case muser_id of
Just user_id -> c ^. CommentVisibility ==. val VisPublic ||. exprUserIsTeamMember user_id project_id ||. exprCommentRootPostedBy user_id c
Nothing -> c ^. CommentVisibility ==. val VisPublic
approvedAndNotFlagged :: SqlExpr (Value Bool)
permissionFilter = case muser_id of
Just user_id -> approvedAndNotFlagged ||. exprCommentPostedBy user_id c ||. exprUserIsModerator user_id project_id
Nothing -> approvedAndNotFlagged
approvedAndNotFlagged = exprCommentApproved c &&. not_ (exprCommentFlagged c)
querCommentAncestors :: CommentId -> SqlQuery (SqlExpr (Value CommentId))
......
module Model.Discussion
( createDiscussionDB
( DiscussionOn(..)
, createDiscussionDB
, fetchDiscussionClosedRootCommentsDB
, fetchDiscussionProjectDB
, fetchDiscussionDB
, fetchDiscussionsDB
, fetchDiscussionRootCommentsDB
, fetchDiscussionWikiPage
, fetchDiscussionWikiPagesInDB
) where
import Import
......@@ -12,6 +12,82 @@ import Import
import Model.Comment.Sql
import Control.Monad.Trans.Maybe
import qualified Data.Map as M
-- | An internal sum type that contains a constructer per database table that acts
-- as a "Discussion". This way, we get a relatively type-safe way of ensuring that
-- all possible such tables are referenced when fetching the data associated with
-- some arbitrary Discussion.
--
-- Any new Discussion-ey tables MUST have a constructor added here! (and below, too)
data DiscussionType
= DiscussionTypeProject
| DiscussionTypeWikiPage
deriving (Bounded, Enum)
-- | Similar to DiscussionType, but exported, and actually contains the data.
data DiscussionOn
= DiscussionOnProject (Entity Project)
| DiscussionOnWikiPage (Entity WikiPage)
-- | Given a 'requested' DiscussionType, attempt to fetch the Discussion from that
-- table. If, say, the requested DiscussionType is DiscussionTypeProject, but the
-- given DiscussionId corresponds to a discussion on a WikiPage, this function
-- will return Nothing.
--
-- TODO(mitchell): Make this function more type safe.
fetchDiscussionInternal :: DiscussionId -> DiscussionType -> DB (Maybe DiscussionOn)
fetchDiscussionInternal discussion_id DiscussionTypeProject = fmap (fmap DiscussionOnProject . listToMaybe) $
select $
from $ \p -> do
where_ (p ^. ProjectDiscussion ==. val discussion_id)
return p
fetchDiscussionInternal discussion_id DiscussionTypeWikiPage = fmap (fmap DiscussionOnWikiPage . listToMaybe) $
select $
from $ \wp -> do
where_ (wp ^. WikiPageDiscussion ==. val discussion_id)
return wp
fetchDiscussionsInternal :: [DiscussionId] -> DiscussionType -> DB (Map DiscussionId DiscussionOn)
fetchDiscussionsInternal discussion_ids DiscussionTypeProject = fmap (foldr go mempty) $
select $
from $ \p -> do
where_ (p ^. ProjectDiscussion `in_` valList discussion_ids)
return p
where
go :: Entity Project -> Map DiscussionId DiscussionOn -> Map DiscussionId DiscussionOn
go p@(Entity _ Project{..}) = M.insert projectDiscussion (DiscussionOnProject p)
fetchDiscussionsInternal discussion_ids DiscussionTypeWikiPage = fmap (foldr go mempty) $
select $
from $ \wp -> do
where_ (wp ^. WikiPageDiscussion `in_` valList discussion_ids)
return wp
where
go :: Entity WikiPage -> Map DiscussionId DiscussionOn -> Map DiscussionId DiscussionOn
go w@(Entity _ WikiPage{..}) = M.insert wikiPageDiscussion (DiscussionOnWikiPage w)
-- | Fetch a single discussion, given its id.
fetchDiscussionDB :: DiscussionId -> DB DiscussionOn
fetchDiscussionDB discussion_id =
fromJustErr "fetchDiscussionDB: discussion not found" <$> runMaybeT (foldr mplus mzero f)
where
-- f :: [MaybeT DB DiscussionOn]
f = map (MaybeT . fetchDiscussionInternal discussion_id) [minBound..maxBound]
-- | Fetch a list of discussions, given their ids. The returned map will have a key for
-- every input DiscussionId.
fetchDiscussionsDB :: [DiscussionId] -> DB (Map DiscussionId DiscussionOn)
fetchDiscussionsDB discussion_ids = do
discussion_map <- mconcat <$> sequence (map (fetchDiscussionsInternal discussion_ids) [minBound..maxBound])
when (M.size discussion_map /= length discussion_ids) $
error "fetchDiscussionsDB: some discussion not found"
return discussion_map
--------------------------------------------------------------------------------
createDiscussionDB :: DB DiscussionId
createDiscussionDB = insert (Discussion 0)
-- | Get all open root Comments on a Discussion.
fetchDiscussionRootCommentsDB :: DiscussionId -> ExprCommentCond -> DB [Entity Comment]
fetchDiscussionRootCommentsDB = fetchRootComments exprCommentOpen
......@@ -30,35 +106,3 @@ fetchRootComments open_or_closed discussion_id has_permission =
open_or_closed c &&.
has_permission c
return c
-- | Given a list of DiscussionId, fetch the discussions which are WikiPages.
fetchDiscussionWikiPagesInDB :: [DiscussionId] -> DB [Entity WikiPage]
fetchDiscussionWikiPagesInDB discussion_ids =
select $
from $ \wp -> do
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)
......@@ -14,6 +14,8 @@ data NotificationType
-- Alert moderators about an unapproved comment.
-- These notifications are auto-deleted when the comment is approved.
| NotifUnapprovedComment
-- User's comment was rethreaded.
| NotifRethreadedComment
-- Reply to a comment made.
| NotifReply
-- Edit conflict.
......@@ -29,6 +31,7 @@ showNotificationType :: NotificationType -> Text
showNotificationType NotifWelcome = "Snowdrift welcome message"
showNotificationType NotifEligEstablish = "You have become eligible for establishment"
showNotificationType NotifUnapprovedComment = "Unapproved comments"
showNotificationType NotifRethreadedComment = "Rethreaded comments"
showNotificationType NotifBalanceLow = "Balance low"
showNotificationType NotifReply = "Replies to my comments"
showNotificationType NotifEditConflict = "Edit conflict"
......
......@@ -2,11 +2,11 @@ module Model.Project
( ProjectSummary(..)
, UpdateProject(..)
, fetchAllProjectsDB
, fetchProjectCommentRethreadsBeforeDB
, fetchProjectCommentsDB
, fetchProjectCommentsBeforeDB
, fetchProjectPendingCommentsBeforeDB
, fetchProjectWikiPageCommentsBeforeDB
, fetchProjectCommentsIncludingRethreadedBeforeDB
, fetchProjectDeletedPledgesBeforeDB
, fetchProjectDiscussionsDB
, fetchProjectNewPledgesBeforeDB
, fetchProjectModeratorsDB
, fetchProjectTeamMembersDB
......@@ -255,46 +255,43 @@ getProjectWikiPages project_id =
orderBy [asc (wp ^. WikiPageTarget)]
return wp
fetchProjectCommentsBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> Int64 -> DB [Entity Comment]
fetchProjectCommentsBeforeDB project_id muser_id before lim =
-- | Fetch all Discussions that are somewhere on the given Project.
fetchProjectDiscussionsDB :: ProjectId -> DB [DiscussionId]
fetchProjectDiscussionsDB project_id = do
pd <- projectDiscussion <$> getJust project_id
wpds <- fmap (map unValue) $
select $
from $ \wp -> do
where_ (wp ^. WikiPageProject ==. val project_id)
return (wp ^. WikiPageDiscussion)
return (pd : wpds)
-- | Get all (posted, not pending) Comments made *somewhere* on a Project, before the given time.
fetchProjectCommentsIncludingRethreadedBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> Int64 -> DB [Entity Comment]
fetchProjectCommentsIncludingRethreadedBeforeDB project_id muser_id before lim = fetchProjectDiscussionsDB project_id >>= \project_discussions ->
select $
from $ \(ecp `InnerJoin` c) -> do
on_ (ecp ^. EventCommentPostedComment ==. c ^. CommentId)
where_ $
ecp ^. EventCommentPostedTs <=. val before &&.
exprCommentProjectPermissionFilter muser_id (val project_id) c &&.
c ^. CommentDiscussion ==. (sub_select $
from $ \p -> do
where_ (p ^. ProjectId ==. val project_id)
return (p ^. ProjectDiscussion))
exprCommentProjectPermissionFilterIncludingRethreaded muser_id (val project_id) c &&.
c ^. CommentDiscussion `in_` valList project_discussions
limit lim
return c
-- | Fetch all Comments posted on this Project's WikiPages before this time.
fetchProjectWikiPageCommentsBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> Int64 -> DB [Entity Comment]
fetchProjectWikiPageCommentsBeforeDB project_id muser_id before lim =
-- | Get all Rethreads whose *destinations* are on the given Project.
fetchProjectCommentRethreadsBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> Int64 -> DB [Entity Rethread]
fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim = fetchProjectDiscussionsDB project_id >>= \project_discussions ->
select $
from $ \(ecp `InnerJoin` c `InnerJoin` wp) -> do
on_ (exprCommentOnWikiPage c wp)
on_ (ecp ^. EventCommentPostedComment ==. c ^. CommentId)
from $ \(ecr `InnerJoin` r `InnerJoin` c) -> do
on_ (r ^. RethreadNewComment ==. c ^. CommentId)
on_ (ecr ^. EventCommentRethreadedRethread ==. r ^. RethreadId)
where_ $
ecp ^. EventCommentPostedTs <=. val before &&.
exprWikiPageOnProject wp project_id &&.
exprCommentProjectPermissionFilter muser_id (val project_id) c
limit lim
return c
-- | Fetch all pending Comments made on a Project before this time.
fetchProjectPendingCommentsBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> Int64 -> DB [Entity Comment]
fetchProjectPendingCommentsBeforeDB project_id muser_id before lim =
select $
from $ \(ecp `InnerJoin` c) -> do
on_ (ecp ^. EventCommentPendingComment ==. c ^. CommentId)
where_ $
ecp ^. EventCommentPendingTs <=. val before &&.
exprCommentProjectPermissionFilter muser_id (val project_id) c
ecr ^. EventCommentRethreadedTs <=. val before &&.
exprCommentProjectPermissionFilter muser_id (val project_id) c &&.
c ^. CommentDiscussion `in_` valList project_discussions
limit lim
return c
return r
-- | Fetch all WikiPages made on this Project before this time.
fetchProjectWikiPagesBeforeDB :: ProjectId -> UTCTime -> Int64 -> DB [Entity WikiPage]
......
......@@ -11,6 +11,7 @@ snowdriftEventNewestToOldest x y = compare (snowdriftEventTime y) (snowdriftEve
snowdriftEventTime :: SnowdriftEvent -> UTCTime
snowdriftEventTime (ECommentPosted _ Comment{..}) = fromMaybe commentCreatedTs commentApprovedTs
snowdriftEventTime (ECommentPending _ Comment{..}) = commentCreatedTs
snowdriftEventTime (ECommentRethreaded _ Rethread{..}) = rethreadTs
snowdriftEventTime (ENotificationSent _ Notification{..}) = notificationCreatedTs
snowdriftEventTime (EWikiEdit _ WikiEdit{..}) = wikiEditTs
snowdriftEventTime (EWikiPage _ WikiPage{..}) = wikiPageCreatedTs
......
......@@ -10,9 +10,11 @@ import Data.Time (UTCTime)
-- A sum type of all events, each of which have their own database table.
data SnowdriftEvent
-- Comment approved.
= ECommentPosted CommentId Comment
= ECommentPosted CommentId Comment
-- Comment unapproved (pending approval).
| ECommentPending CommentId Comment
-- Comment rethreaded.
| ECommentRethreaded RethreadId Rethread -- rethreaded-from-URL
| ENotificationSent NotificationId Notification
-- New WikiEdit made.
| EWikiEdit WikiEditId WikiEdit
......@@ -21,7 +23,7 @@ data SnowdriftEvent
-- New pledge.
| ENewPledge SharesPledgedId SharesPledged
-- Pledge that has changed in value.
| EUpdatedPledge Int64 {- old shares -}
SharesPledgedId SharesPledged {- new pledge info -}
| EUpdatedPledge Int64 -- old shares
SharesPledgedId SharesPledged -- new pledge info
-- Deleted pledge.
| EDeletedPledge UTCTime UserId ProjectId Int64
......@@ -116,6 +116,7 @@ library
DeriveDataTypeable
DeriveFunctor
EmptyDataDecls
ExistentialQuantification
FlexibleContexts
FlexibleInstances
GADTs
......
......@@ -4,18 +4,15 @@ module SnowdriftEventHandler
import Import
import Model.Discussion
import Model.Notification
import Model.Project
import Model.User
import Handler.Utils
import Model.Comment
import Model.Discussion
import Model.Notification
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 Data.Maybe (fromJust)
import qualified Database.Persist
import Yesod (renderRoute)
import Yesod.Markdown
-- Add more event handlers here.
......@@ -37,9 +34,8 @@ notificationEventHandler (ECommentPosted comment_id comment) = case commentParen
return (parent_user_id, delivery)
-- Any non-Nothing delivery implies an internal Notification 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
parent_comment_route <- routeToText (CommentDirectLinkR parent_comment_id)
reply_comment_route <- routeToText (CommentDirectLinkR comment_id)
let content = mconcat
[ "Someone replied to [your comment]("
......@@ -51,28 +47,54 @@ notificationEventHandler (ECommentPosted comment_id comment) = case commentParen
, "*You can filter these notifications by adjusting the settings in your profile.*"
]
runSDB (sendNotificationDB_ NotifReply parent_user_id Nothing content)
-- Notify all moderators of the project the comment was posted on.
notificationEventHandler (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
runSDB $ do
(Entity project_id project) <- lift (fetchDiscussionDB (commentDiscussion comment)) >>= \case
DiscussionOnProject project -> return project
DiscussionOnWikiPage (Entity _ WikiPage{..}) -> Entity wikiPageProject <$> getJust wikiPageProject
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)
, ")."
]
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 "