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

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
import View.Comment
import Widgets.Tag
import Control.Monad.Writer (tell)
import Data.Default (def)
import Data.Tree (Forest, Tree, rootLabel)
import qualified Data.Map as M
......@@ -325,7 +327,10 @@ postCloseComment user@(Entity user_id _) comment_id comment make_comment_handler
let closing = CommentClosing now user_id reason comment_id
lookupPostMode >>= \case
Just PostMode -> do
runDB (insert_ closing)
runSDB $ do
closing_id <- insert closing
tell [ECommentClosed closing_id closing]
return Nothing
_ -> do
(form, _) <- generateFormPost (closeCommentForm (Just reason))
......
......@@ -864,7 +864,7 @@ getProjectFeedR project_handle = do
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,
earlier_closures_map, earlier_retracts_map, closure_map, retract_map,
ticket_map, claim_map, flag_map) <- runYDB $ do
......@@ -873,6 +873,7 @@ getProjectFeedR project_handle = do
comments <- fetchProjectCommentsIncludingRethreadedBeforeDB 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
unclaimings <- fetchProjectTicketUnclaimingsBeforeDB project_id before lim
wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim
......@@ -892,6 +893,7 @@ getProjectFeedR project_handle = do
-- All users: comment posters, wiki page creators, etc.
user_ids = S.toList $ mconcat
[ S.fromList comment_users
, S.fromList (map (commentClosingClosedBy . entityVal) closings)
, S.fromList (map (rethreadModerator . entityVal) rethreads)
, S.fromList wiki_edit_users
, S.fromList blog_post_users
......@@ -902,7 +904,10 @@ getProjectFeedR project_handle = do
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)
wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB wiki_edit_pages
......@@ -916,7 +921,7 @@ getProjectFeedR project_handle = do
claim_map <- makeClaimedTicketMapDB 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,
wiki_page_map, user_map, earlier_closures_map,
earlier_retracts_map, closure_map, retract_map, ticket_map,
......@@ -927,6 +932,7 @@ getProjectFeedR project_handle = do
let all_unsorted_events = mconcat
[ map (onEntity ECommentPosted) comments
, map (onEntity ECommentRethreaded) rethreads
, map (onEntity ECommentClosed) closings
, map (onEntity ETicketClaimed) claimings
, map (onEntity ETicketUnclaimed) unclaimings
, map (onEntity EWikiPage) wiki_pages
......
......@@ -42,7 +42,7 @@ module Model.Comment
, fetchCommentsDescendantsDB
, fetchCommentsInDB
, fetchCommentsWithChildrenInDB
, fetchClaimedTicketsDB
, fetchCommentTicketsDB
, filterCommentsDB
, makeClaimedTicketMapDB
, makeCommentClosingMapDB
......@@ -739,10 +739,10 @@ rethreadCommentDB mnew_parent_id new_discussion_id root_comment_id user_id reaso
<# (vc ^. ViewCommentUser)
<&> (cr ^. CommentRethreadNewComment))
fetchClaimedTicketsDB :: [Entity TicketClaiming] -> DB (Map CommentId (Entity Ticket))
fetchClaimedTicketsDB ticket_claimings = do
fetchCommentTicketsDB :: Set CommentId -> DB (Map CommentId (Entity Ticket))
fetchCommentTicketsDB comment_ids = 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 $ M.fromList $ map (ticketComment . entityVal &&& id) ticket_entities
......
......@@ -4,6 +4,7 @@ module Model.Project
, fetchPublicProjectsDB
, fetchProjectCommentRethreadsBeforeDB
, fetchProjectCommentsIncludingRethreadedBeforeDB
, fetchProjectCommentClosingsBeforeDB
, fetchProjectDeletedPledgesBeforeDB
, fetchProjectDiscussionsDB
, fetchProjectNewPledgesBeforeDB
......@@ -285,6 +286,19 @@ fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim = fetchProje
limit lim
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 project_id before lim = fetchProjectDiscussionsDB project_id >>= \project_discussions ->
select $ from $ \ (tc `InnerJoin` c `InnerJoin` t) -> do
......
......@@ -22,6 +22,7 @@ snowdriftEventTime :: SnowdriftEvent -> UTCTime
snowdriftEventTime (ECommentPosted _ Comment{..}) = fromMaybe commentCreatedTs commentApprovedTs
snowdriftEventTime (ECommentPending _ Comment{..}) = commentCreatedTs
snowdriftEventTime (ECommentRethreaded _ Rethread{..}) = rethreadTs
snowdriftEventTime (ECommentClosed _ CommentClosing{..}) = commentClosingTs
snowdriftEventTime (ETicketClaimed _ TicketClaiming{..}) = ticketClaimingTs
snowdriftEventTime (ETicketUnclaimed _ TicketClaiming{..}) = fromMaybe (error "TicketUnclaimed event for TicketClaiming with no ReleasedTs") ticketClaimingReleasedTs
snowdriftEventTime (ENotificationSent _ Notification{..}) = notificationCreatedTs
......@@ -66,6 +67,37 @@ snowdriftEventToFeedEntry render project_handle _ _ _ _ (ECommentRethreaded _ re
, 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{..}) =
let user_id = ticketClaimingUser
maybe_user = M.lookup user_id user_map
......
......@@ -11,25 +11,39 @@ import Data.Time (UTCTime)
data SnowdriftEvent
-- Comment approved.
= ECommentPosted CommentId Comment
-- Comment unapproved (pending approval).
| ECommentPending CommentId Comment
-- Comment closed (ticket or otherwise)
| ECommentClosed CommentClosingId CommentClosing
-- Ticket claimed
| ETicketClaimed TicketClaimingId TicketClaiming
-- Ticket unclaimed
| ETicketUnclaimed TicketClaimingId TicketClaiming
-- Comment rethreaded.
| ECommentRethreaded RethreadId Rethread -- rethreaded-from-URL
| ENotificationSent NotificationId Notification
-- New WikiEdit made.
| EWikiEdit WikiEditId WikiEdit
-- New WikiPage posted.
| EWikiPage WikiPageId WikiPage
-- New blog post posted.
| EBlogPost BlogPostId BlogPost
-- New pledge.
| ENewPledge SharesPledgedId SharesPledged
-- Pledge that has changed in value.
| EUpdatedPledge Int64 -- old shares
SharesPledgedId SharesPledged -- new pledge info
-- Deleted pledge.
| EDeletedPledge UTCTime UserId ProjectId Int64
......@@ -93,6 +93,8 @@ notificationEventHandler (ECommentRethreaded _ Rethread{..}) = do
runSDB (sendNotificationDB_ NotifRethreadedComment (commentUser comment) Nothing content)
notificationEventHandler (ECommentClosed _ _) = return ()
-- TODO: Send notification to anyone watching thread
notificationEventHandler (ETicketClaimed _ _) = return ()
notificationEventHandler (ETicketUnclaimed _ _) = return ()
......@@ -111,6 +113,7 @@ eventInserterHandler :: SnowdriftEvent -> Daemon ()
eventInserterHandler (ECommentPosted comment_id Comment{..}) = runDB (insert_ (EventCommentPosted (fromJust commentApprovedTs) 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 (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 (ETicketUnclaimed ticket_claiming_id TicketClaiming{..}) =
......
......@@ -130,6 +130,33 @@ renderCommentRethreadedEvent Rethread{..} user_map = do
: #{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{..} user_map ticket_map = do
let user = lookupErr "renderTicketClaimedEvent: claiming user not found in user map" ticketClaimingUser user_map
......
......@@ -423,6 +423,11 @@ EventCommentRethreaded
ts UTCTime
rethread RethreadId
-- An approved comment.
EventCommentClosing
ts UTCTime
comment_closing CommentClosingId
EventTicketClaimed
ts UTCTime
claim TicketClaimingId
......
......@@ -8,6 +8,9 @@ $forall event <- events
$of ECommentRethreaded _ rethread
^{renderCommentRethreadedEvent rethread user_map}
$of ECommentClosed _ comment_closing
^{renderCommentClosedEvent comment_closing user_map ticket_map}
$of ETicketClaimed _ claim
^{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