Commit 4aa9bc63 authored by David L. L. Thomas's avatar David L. L. Thomas

Events for closing comments/tickets

Closes SD-250
parent 16506a43
...@@ -57,6 +57,8 @@ import Model.Tag ...@@ -57,6 +57,8 @@ import Model.Tag
import View.Comment import View.Comment
import Widgets.Tag import Widgets.Tag
import Control.Monad.Writer (tell)
import Data.Default (def) import Data.Default (def)
import Data.Tree (Forest, Tree, rootLabel) import Data.Tree (Forest, Tree, rootLabel)
import qualified Data.Map as M import qualified Data.Map as M
...@@ -325,7 +327,10 @@ postCloseComment user@(Entity user_id _) comment_id comment make_comment_handler ...@@ -325,7 +327,10 @@ postCloseComment user@(Entity user_id _) comment_id comment make_comment_handler
let closing = CommentClosing now user_id reason comment_id let closing = CommentClosing now user_id reason comment_id
lookupPostMode >>= \case lookupPostMode >>= \case
Just PostMode -> do Just PostMode -> do
runDB (insert_ closing) runSDB $ do
closing_id <- insert closing
tell [ECommentClosed closing_id closing]
return Nothing return Nothing
_ -> do _ -> do
(form, _) <- generateFormPost (closeCommentForm (Just reason)) (form, _) <- generateFormPost (closeCommentForm (Just reason))
......
...@@ -864,7 +864,7 @@ getProjectFeedR project_handle = do ...@@ -864,7 +864,7 @@ getProjectFeedR project_handle = do
before <- lookupGetUTCTimeDefaultNow "before" before <- lookupGetUTCTimeDefaultNow "before"
(project, comments, rethreads, claimings, unclaimings, wiki_pages, wiki_edits, blog_posts, new_pledges, (project, comments, rethreads, closings, claimings, unclaimings, wiki_pages, wiki_edits, blog_posts, new_pledges,
updated_pledges, deleted_pledges, discussion_map, wiki_page_map, user_map, updated_pledges, deleted_pledges, discussion_map, wiki_page_map, user_map,
earlier_closures_map, earlier_retracts_map, closure_map, retract_map, earlier_closures_map, earlier_retracts_map, closure_map, retract_map,
ticket_map, claim_map, flag_map) <- runYDB $ do ticket_map, claim_map, flag_map) <- runYDB $ do
...@@ -873,6 +873,7 @@ getProjectFeedR project_handle = do ...@@ -873,6 +873,7 @@ getProjectFeedR project_handle = do
comments <- fetchProjectCommentsIncludingRethreadedBeforeDB project_id muser_id before lim comments <- fetchProjectCommentsIncludingRethreadedBeforeDB project_id muser_id before lim
rethreads <- fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim rethreads <- fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim
closings <- fetchProjectCommentClosingsBeforeDB project_id muser_id before lim
claimings <- fetchProjectTicketClaimingsBeforeDB project_id before lim claimings <- fetchProjectTicketClaimingsBeforeDB project_id before lim
unclaimings <- fetchProjectTicketUnclaimingsBeforeDB project_id before lim unclaimings <- fetchProjectTicketUnclaimingsBeforeDB project_id before lim
wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim
...@@ -892,6 +893,7 @@ getProjectFeedR project_handle = do ...@@ -892,6 +893,7 @@ getProjectFeedR project_handle = do
-- All users: comment posters, wiki page creators, etc. -- All users: comment posters, wiki page creators, etc.
user_ids = S.toList $ mconcat user_ids = S.toList $ mconcat
[ S.fromList comment_users [ S.fromList comment_users
, S.fromList (map (commentClosingClosedBy . entityVal) closings)
, S.fromList (map (rethreadModerator . entityVal) rethreads) , S.fromList (map (rethreadModerator . entityVal) rethreads)
, S.fromList wiki_edit_users , S.fromList wiki_edit_users
, S.fromList blog_post_users , S.fromList blog_post_users
...@@ -902,7 +904,10 @@ getProjectFeedR project_handle = do ...@@ -902,7 +904,10 @@ getProjectFeedR project_handle = do
discussion_map <- fetchProjectDiscussionsDB project_id >>= fetchDiscussionsDB discussion_map <- fetchProjectDiscussionsDB project_id >>= fetchDiscussionsDB
ticket_map <- fetchClaimedTicketsDB (claimings <> unclaimings) ticket_map <- fetchCommentTicketsDB $ mconcat
[ S.fromList comment_ids
, S.fromList $ map (ticketClaimingTicket . entityVal) $ claimings <> unclaimings
]
-- WikiPages keyed by their own IDs (contained in a WikiEdit) -- WikiPages keyed by their own IDs (contained in a WikiEdit)
wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB wiki_edit_pages wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB wiki_edit_pages
...@@ -916,7 +921,7 @@ getProjectFeedR project_handle = do ...@@ -916,7 +921,7 @@ getProjectFeedR project_handle = do
claim_map <- makeClaimedTicketMapDB comment_ids claim_map <- makeClaimedTicketMapDB comment_ids
flag_map <- makeFlagMapDB comment_ids flag_map <- makeFlagMapDB comment_ids
return (project, comments, rethreads, claimings, unclaimings, wiki_pages, wiki_edits, blog_posts, return (project, comments, rethreads, closings, claimings, unclaimings, wiki_pages, wiki_edits, blog_posts,
new_pledges, updated_pledges, deleted_pledges, discussion_map, new_pledges, updated_pledges, deleted_pledges, discussion_map,
wiki_page_map, user_map, earlier_closures_map, wiki_page_map, user_map, earlier_closures_map,
earlier_retracts_map, closure_map, retract_map, ticket_map, earlier_retracts_map, closure_map, retract_map, ticket_map,
...@@ -927,6 +932,7 @@ getProjectFeedR project_handle = do ...@@ -927,6 +932,7 @@ getProjectFeedR project_handle = do
let all_unsorted_events = mconcat let all_unsorted_events = mconcat
[ map (onEntity ECommentPosted) comments [ map (onEntity ECommentPosted) comments
, map (onEntity ECommentRethreaded) rethreads , map (onEntity ECommentRethreaded) rethreads
, map (onEntity ECommentClosed) closings
, map (onEntity ETicketClaimed) claimings , map (onEntity ETicketClaimed) claimings
, map (onEntity ETicketUnclaimed) unclaimings , map (onEntity ETicketUnclaimed) unclaimings
, map (onEntity EWikiPage) wiki_pages , map (onEntity EWikiPage) wiki_pages
......
...@@ -42,7 +42,7 @@ module Model.Comment ...@@ -42,7 +42,7 @@ module Model.Comment
, fetchCommentsDescendantsDB , fetchCommentsDescendantsDB
, fetchCommentsInDB , fetchCommentsInDB
, fetchCommentsWithChildrenInDB , fetchCommentsWithChildrenInDB
, fetchClaimedTicketsDB , fetchCommentTicketsDB
, filterCommentsDB , filterCommentsDB
, makeClaimedTicketMapDB , makeClaimedTicketMapDB
, makeCommentClosingMapDB , makeCommentClosingMapDB
...@@ -739,10 +739,10 @@ rethreadCommentDB mnew_parent_id new_discussion_id root_comment_id user_id reaso ...@@ -739,10 +739,10 @@ rethreadCommentDB mnew_parent_id new_discussion_id root_comment_id user_id reaso
<# (vc ^. ViewCommentUser) <# (vc ^. ViewCommentUser)
<&> (cr ^. CommentRethreadNewComment)) <&> (cr ^. CommentRethreadNewComment))
fetchClaimedTicketsDB :: [Entity TicketClaiming] -> DB (Map CommentId (Entity Ticket)) fetchCommentTicketsDB :: Set CommentId -> DB (Map CommentId (Entity Ticket))
fetchClaimedTicketsDB ticket_claimings = do fetchCommentTicketsDB comment_ids = do
ticket_entities <- select $ from $ \ t -> do ticket_entities <- select $ from $ \ t -> do
where_ $ t ^. TicketComment `in_` valList (map (ticketClaimingTicket . entityVal) ticket_claimings) where_ $ t ^. TicketComment `in_` valList (S.toList comment_ids)
return t return t
return $ M.fromList $ map (ticketComment . entityVal &&& id) ticket_entities return $ M.fromList $ map (ticketComment . entityVal &&& id) ticket_entities
......
...@@ -4,6 +4,7 @@ module Model.Project ...@@ -4,6 +4,7 @@ module Model.Project
, fetchPublicProjectsDB , fetchPublicProjectsDB
, fetchProjectCommentRethreadsBeforeDB , fetchProjectCommentRethreadsBeforeDB
, fetchProjectCommentsIncludingRethreadedBeforeDB , fetchProjectCommentsIncludingRethreadedBeforeDB
, fetchProjectCommentClosingsBeforeDB
, fetchProjectDeletedPledgesBeforeDB , fetchProjectDeletedPledgesBeforeDB
, fetchProjectDiscussionsDB , fetchProjectDiscussionsDB
, fetchProjectNewPledgesBeforeDB , fetchProjectNewPledgesBeforeDB
...@@ -285,6 +286,19 @@ fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim = fetchProje ...@@ -285,6 +286,19 @@ fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim = fetchProje
limit lim limit lim
return r return r
-- | Get all Closings for comments on the current project
fetchProjectCommentClosingsBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> Int64 -> DB [Entity CommentClosing]
fetchProjectCommentClosingsBeforeDB project_id muser_id before lim = fetchProjectDiscussionsDB project_id >>= \project_discussions ->
select $ from $ \(closing `InnerJoin` comment) -> do
on_ (closing ^. CommentClosingComment ==. comment ^. CommentId)
where_ $ closing ^. CommentClosingTs <=. val before
&&. exprCommentProjectPermissionFilter muser_id (val project_id) comment
&&. comment ^. CommentDiscussion `in_` valList project_discussions
orderBy [ desc $ closing ^. CommentClosingTs, desc $ closing ^. CommentClosingId ]
limit lim
return closing
fetchProjectTicketClaimingsBeforeDB :: ProjectId -> UTCTime -> Int64 -> DB [Entity TicketClaiming] fetchProjectTicketClaimingsBeforeDB :: ProjectId -> UTCTime -> Int64 -> DB [Entity TicketClaiming]
fetchProjectTicketClaimingsBeforeDB project_id before lim = fetchProjectDiscussionsDB project_id >>= \project_discussions -> fetchProjectTicketClaimingsBeforeDB project_id before lim = fetchProjectDiscussionsDB project_id >>= \project_discussions ->
select $ from $ \ (tc `InnerJoin` c `InnerJoin` t) -> do select $ from $ \ (tc `InnerJoin` c `InnerJoin` t) -> do
......
...@@ -22,6 +22,7 @@ snowdriftEventTime :: SnowdriftEvent -> UTCTime ...@@ -22,6 +22,7 @@ snowdriftEventTime :: SnowdriftEvent -> UTCTime
snowdriftEventTime (ECommentPosted _ Comment{..}) = fromMaybe commentCreatedTs commentApprovedTs snowdriftEventTime (ECommentPosted _ Comment{..}) = fromMaybe commentCreatedTs commentApprovedTs
snowdriftEventTime (ECommentPending _ Comment{..}) = commentCreatedTs snowdriftEventTime (ECommentPending _ Comment{..}) = commentCreatedTs
snowdriftEventTime (ECommentRethreaded _ Rethread{..}) = rethreadTs snowdriftEventTime (ECommentRethreaded _ Rethread{..}) = rethreadTs
snowdriftEventTime (ECommentClosed _ CommentClosing{..}) = commentClosingTs
snowdriftEventTime (ETicketClaimed _ TicketClaiming{..}) = ticketClaimingTs snowdriftEventTime (ETicketClaimed _ TicketClaiming{..}) = ticketClaimingTs
snowdriftEventTime (ETicketUnclaimed _ TicketClaiming{..}) = fromMaybe (error "TicketUnclaimed event for TicketClaiming with no ReleasedTs") ticketClaimingReleasedTs snowdriftEventTime (ETicketUnclaimed _ TicketClaiming{..}) = fromMaybe (error "TicketUnclaimed event for TicketClaiming with no ReleasedTs") ticketClaimingReleasedTs
snowdriftEventTime (ENotificationSent _ Notification{..}) = notificationCreatedTs snowdriftEventTime (ENotificationSent _ Notification{..}) = notificationCreatedTs
...@@ -66,6 +67,37 @@ snowdriftEventToFeedEntry render project_handle _ _ _ _ (ECommentRethreaded _ re ...@@ -66,6 +67,37 @@ snowdriftEventToFeedEntry render project_handle _ _ _ _ (ECommentRethreaded _ re
, feedEntryContent = [hamlet| |] render , feedEntryContent = [hamlet| |] render
} }
snowdriftEventToFeedEntry render project_handle user_map _ _ ticket_map (ECommentClosed _ CommentClosing{..}) =
let user_id = commentClosingClosedBy
maybe_user = M.lookup user_id user_map
username = maybe "<unknown user>" (userDisplayName . Entity user_id) maybe_user
mk_feed_entry title = Just $ FeedEntry
{ feedEntryLink = CommentDirectLinkR commentClosingComment
, feedEntryUpdated = commentClosingTs
, feedEntryTitle = title
, feedEntryContent = [hamlet| |] render
}
in case M.lookup commentClosingComment ticket_map of
Just (Entity ticket_id Ticket{..}) ->
let ticket_str = case ticket_id of
Key (PersistInt64 tid) -> T.pack $ show tid
Key _ -> "<malformed id>"
in mk_feed_entry $ T.unwords
[ T.snoc project_handle ':'
, "ticket closed by"
, T.snoc username ':'
, T.concat [ "SD-", ticket_str, ":" ]
, ticketName
]
Nothing -> mk_feed_entry $ T.unwords
[ T.snoc project_handle ':'
, "comment thread closed by"
, username
]
snowdriftEventToFeedEntry render project_handle user_map _ _ ticket_map (ETicketClaimed _ TicketClaiming{..}) = snowdriftEventToFeedEntry render project_handle user_map _ _ ticket_map (ETicketClaimed _ TicketClaiming{..}) =
let user_id = ticketClaimingUser let user_id = ticketClaimingUser
maybe_user = M.lookup user_id user_map maybe_user = M.lookup user_id user_map
......
...@@ -11,25 +11,39 @@ import Data.Time (UTCTime) ...@@ -11,25 +11,39 @@ import Data.Time (UTCTime)
data SnowdriftEvent data SnowdriftEvent
-- Comment approved. -- Comment approved.
= ECommentPosted CommentId Comment = ECommentPosted CommentId Comment
-- Comment unapproved (pending approval). -- Comment unapproved (pending approval).
| ECommentPending CommentId Comment | ECommentPending CommentId Comment
-- Comment closed (ticket or otherwise)
| ECommentClosed CommentClosingId CommentClosing
-- Ticket claimed -- Ticket claimed
| ETicketClaimed TicketClaimingId TicketClaiming | ETicketClaimed TicketClaimingId TicketClaiming
-- Ticket unclaimed -- Ticket unclaimed
| ETicketUnclaimed TicketClaimingId TicketClaiming | ETicketUnclaimed TicketClaimingId TicketClaiming
-- Comment rethreaded. -- Comment rethreaded.
| ECommentRethreaded RethreadId Rethread -- rethreaded-from-URL | ECommentRethreaded RethreadId Rethread -- rethreaded-from-URL
| ENotificationSent NotificationId Notification | ENotificationSent NotificationId Notification
-- New WikiEdit made. -- New WikiEdit made.
| EWikiEdit WikiEditId WikiEdit | EWikiEdit WikiEditId WikiEdit
-- New WikiPage posted. -- New WikiPage posted.
| EWikiPage WikiPageId WikiPage | EWikiPage WikiPageId WikiPage
-- New blog post posted. -- New blog post posted.
| EBlogPost BlogPostId BlogPost | EBlogPost BlogPostId BlogPost
-- New pledge. -- New pledge.
| ENewPledge SharesPledgedId SharesPledged | ENewPledge SharesPledgedId SharesPledged
-- Pledge that has changed in value. -- Pledge that has changed in value.
| EUpdatedPledge Int64 -- old shares | EUpdatedPledge Int64 -- old shares
SharesPledgedId SharesPledged -- new pledge info SharesPledgedId SharesPledged -- new pledge info
-- Deleted pledge. -- Deleted pledge.
| EDeletedPledge UTCTime UserId ProjectId Int64 | EDeletedPledge UTCTime UserId ProjectId Int64
...@@ -93,6 +93,8 @@ notificationEventHandler (ECommentRethreaded _ Rethread{..}) = do ...@@ -93,6 +93,8 @@ notificationEventHandler (ECommentRethreaded _ Rethread{..}) = do
runSDB (sendNotificationDB_ NotifRethreadedComment (commentUser comment) Nothing content) runSDB (sendNotificationDB_ NotifRethreadedComment (commentUser comment) Nothing content)
notificationEventHandler (ECommentClosed _ _) = return ()
-- TODO: Send notification to anyone watching thread -- TODO: Send notification to anyone watching thread
notificationEventHandler (ETicketClaimed _ _) = return () notificationEventHandler (ETicketClaimed _ _) = return ()
notificationEventHandler (ETicketUnclaimed _ _) = return () notificationEventHandler (ETicketUnclaimed _ _) = return ()
...@@ -111,6 +113,7 @@ eventInserterHandler :: SnowdriftEvent -> Daemon () ...@@ -111,6 +113,7 @@ eventInserterHandler :: SnowdriftEvent -> Daemon ()
eventInserterHandler (ECommentPosted comment_id Comment{..}) = runDB (insert_ (EventCommentPosted (fromJust commentApprovedTs) comment_id)) eventInserterHandler (ECommentPosted comment_id Comment{..}) = runDB (insert_ (EventCommentPosted (fromJust commentApprovedTs) comment_id))
eventInserterHandler (ECommentPending comment_id Comment{..}) = runDB (insert_ (EventCommentPending commentCreatedTs comment_id)) eventInserterHandler (ECommentPending comment_id Comment{..}) = runDB (insert_ (EventCommentPending commentCreatedTs comment_id))
eventInserterHandler (ECommentRethreaded rethread_id Rethread{..}) = runDB (insert_ (EventCommentRethreaded rethreadTs rethread_id)) eventInserterHandler (ECommentRethreaded rethread_id Rethread{..}) = runDB (insert_ (EventCommentRethreaded rethreadTs rethread_id))
eventInserterHandler (ECommentClosed comment_closing_id CommentClosing{..}) = runDB (insert_ (EventCommentClosing commentClosingTs comment_closing_id))
eventInserterHandler (ETicketClaimed ticket_claiming_id TicketClaiming{..}) = runDB (insert_ (EventTicketClaimed ticketClaimingTs ticket_claiming_id)) eventInserterHandler (ETicketClaimed ticket_claiming_id TicketClaiming{..}) = runDB (insert_ (EventTicketClaimed ticketClaimingTs ticket_claiming_id))
eventInserterHandler (ETicketUnclaimed ticket_claiming_id TicketClaiming{..}) = eventInserterHandler (ETicketUnclaimed ticket_claiming_id TicketClaiming{..}) =
......
...@@ -130,6 +130,33 @@ renderCommentRethreadedEvent Rethread{..} user_map = do ...@@ -130,6 +130,33 @@ renderCommentRethreadedEvent Rethread{..} user_map = do
: #{rethreadReason} : #{rethreadReason}
|] |]
renderCommentClosedEvent :: CommentClosing -> UserMap -> Map CommentId (Entity Ticket) -> Widget
renderCommentClosedEvent CommentClosing{..} user_map ticket_map = do
let user = lookupErr "renderCommentClosedEvent: closing user not found in user map" commentClosingClosedBy user_map
case M.lookup commentClosingComment ticket_map of
Just (Entity ticket_id Ticket{..}) -> do
let ticket_str = case ticket_id of
Key (PersistInt64 tid) -> T.pack $ show tid
Key _ -> "<malformed key>"
[whamlet|
<div .event>
^{renderTime commentClosingTs}
<a href=@{UserR commentClosingClosedBy}> #{userDisplayName (Entity commentClosingClosedBy user)}
closed ticket
<a href=@{CommentDirectLinkR commentClosingComment}>
<div .ticket-title>SD-#{ticket_str}: #{ticketName}
|]
Nothing -> do
[whamlet|
<div .event>
^{renderTime commentClosingTs}
<a href=@{UserR commentClosingClosedBy}> #{userDisplayName (Entity commentClosingClosedBy user)}
closed comment thread
|]
renderTicketClaimedEvent :: TicketClaiming -> UserMap -> Map CommentId (Entity Ticket) -> Widget renderTicketClaimedEvent :: TicketClaiming -> UserMap -> Map CommentId (Entity Ticket) -> Widget
renderTicketClaimedEvent TicketClaiming{..} user_map ticket_map = do renderTicketClaimedEvent TicketClaiming{..} user_map ticket_map = do
let user = lookupErr "renderTicketClaimedEvent: claiming user not found in user map" ticketClaimingUser user_map let user = lookupErr "renderTicketClaimedEvent: claiming user not found in user map" ticketClaimingUser user_map
......
...@@ -423,6 +423,11 @@ EventCommentRethreaded ...@@ -423,6 +423,11 @@ EventCommentRethreaded
ts UTCTime ts UTCTime
rethread RethreadId rethread RethreadId
-- An approved comment.
EventCommentClosing
ts UTCTime
comment_closing CommentClosingId
EventTicketClaimed EventTicketClaimed
ts UTCTime ts UTCTime
claim TicketClaimingId claim TicketClaimingId
......
...@@ -8,6 +8,9 @@ $forall event <- events ...@@ -8,6 +8,9 @@ $forall event <- events
$of ECommentRethreaded _ rethread $of ECommentRethreaded _ rethread
^{renderCommentRethreadedEvent rethread user_map} ^{renderCommentRethreadedEvent rethread user_map}
$of ECommentClosed _ comment_closing
^{renderCommentClosedEvent comment_closing user_map ticket_map}
$of ETicketClaimed _ claim $of ETicketClaimed _ claim
^{renderTicketClaimedEvent claim user_map ticket_map} ^{renderTicketClaimedEvent claim user_map ticket_map}
......
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