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

Commit 16506a43 authored by David L. L. Thomas's avatar David L. L. Thomas

Ticket claiming events

parent 5e2282aa
......@@ -291,7 +291,7 @@ postClaimComment user@(Entity user_id _) comment_id comment make_comment_handler
FormSuccess mnote -> do
lookupPostMode >>= \case
Just PostMode -> do
runDB (userClaimCommentDB user_id comment_id mnote)
runSDB (userClaimCommentDB user_id comment_id mnote)
return Nothing
_ -> do
now <- liftIO getCurrentTime
......@@ -303,7 +303,7 @@ postClaimComment user@(Entity user_id _) comment_id comment make_comment_handler
(Entity comment_id comment)
user
make_comment_handler_info
(def { mod_claim_map = M.insert comment_id (TicketClaiming now user_id comment_id mnote) })
(def { mod_claim_map = M.insert comment_id (TicketClaiming now user_id comment_id mnote Nothing) })
(getMaxDepthDefault 0)
True
return (Just (comment_widget, form))
......@@ -601,7 +601,7 @@ postUnclaimComment user@(Entity user_id _) comment_id comment make_comment_handl
FormSuccess mnote -> do
lookupPostMode >>= \case
Just PostMode -> do
runDB (userUnclaimCommentDB user_id comment_id mnote)
runSDB (userUnclaimCommentDB user_id comment_id mnote)
return Nothing
_ -> do
(form, _) <- generateFormPost (claimCommentForm (Just mnote))
......
......@@ -864,7 +864,7 @@ getProjectFeedR project_handle = do
before <- lookupGetUTCTimeDefaultNow "before"
(project, comments, rethreads, wiki_pages, wiki_edits, blog_posts, new_pledges,
(project, comments, rethreads, 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,8 @@ getProjectFeedR project_handle = do
comments <- fetchProjectCommentsIncludingRethreadedBeforeDB project_id muser_id before lim
rethreads <- fetchProjectCommentRethreadsBeforeDB 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
blog_posts <- fetchProjectBlogPostsBeforeDB project_id before lim
wiki_edits <- fetchProjectWikiEditsBeforeDB project_id before lim
......@@ -893,12 +895,15 @@ getProjectFeedR project_handle = do
, S.fromList (map (rethreadModerator . entityVal) rethreads)
, S.fromList wiki_edit_users
, S.fromList blog_post_users
, S.fromList (map (ticketClaimingUser . entityVal) (claimings <> unclaimings))
, S.fromList (map sharesPledgedUser shares_pledged)
, S.fromList (map eventDeletedPledgeUser deleted_pledges)
]
discussion_map <- fetchProjectDiscussionsDB project_id >>= fetchDiscussionsDB
ticket_map <- fetchClaimedTicketsDB (claimings <> unclaimings)
-- WikiPages keyed by their own IDs (contained in a WikiEdit)
wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB wiki_edit_pages
......@@ -908,11 +913,10 @@ getProjectFeedR project_handle = do
earlier_retracts_map <- fetchCommentsAncestorRetractsDB comment_ids
closure_map <- makeCommentClosingMapDB comment_ids
retract_map <- makeCommentRetractingMapDB comment_ids
ticket_map <- makeTicketMapDB comment_ids
claim_map <- makeClaimedTicketMapDB comment_ids
flag_map <- makeFlagMapDB comment_ids
return (project, comments, rethreads, wiki_pages, wiki_edits, blog_posts,
return (project, comments, rethreads, 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,
......@@ -923,6 +927,8 @@ getProjectFeedR project_handle = do
let all_unsorted_events = mconcat
[ map (onEntity ECommentPosted) comments
, map (onEntity ECommentRethreaded) rethreads
, map (onEntity ETicketClaimed) claimings
, map (onEntity ETicketUnclaimed) unclaimings
, map (onEntity EWikiPage) wiki_pages
, map (onEntity EWikiEdit) wiki_edits
, map (onEntity EBlogPost) blog_posts
......@@ -950,7 +956,8 @@ getProjectFeedR project_handle = do
project_handle
user_map
discussion_map
wiki_page_map) events
wiki_page_map
ticket_map) events
selectRep $ do
provideRep $ atomFeed feed
......@@ -1167,6 +1174,7 @@ getTicketsR project_handle = do
setTitle . toHtml $ projectName project <> " Tickets | Snowdrift.coop"
$(widgetFile "tickets")
--------------------------------------------------------------------------------
-- /transactions
......
......@@ -42,6 +42,7 @@ module Model.Comment
, fetchCommentsDescendantsDB
, fetchCommentsInDB
, fetchCommentsWithChildrenInDB
, fetchClaimedTicketsDB
, filterCommentsDB
, makeClaimedTicketMapDB
, makeCommentClosingMapDB
......@@ -725,7 +726,8 @@ rethreadCommentDB mnew_parent_id new_discussion_id root_comment_id user_id reaso
<# (tc ^. TicketClaimingTs)
<&> (tc ^. TicketClaimingUser)
<&> (cr ^. CommentRethreadNewComment)
<&> (tc ^. TicketClaimingNote))
<&> (tc ^. TicketClaimingNote)
<&> (tc ^. TicketClaimingReleasedTs))
updateForRethread UnapprovedCommentNotificationComment
(\ucn cr -> UnapprovedCommentNotification
......@@ -737,6 +739,14 @@ 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
ticket_entities <- select $ from $ \ t -> do
where_ $ t ^. TicketComment `in_` valList (map (ticketClaimingTicket . entityVal) ticket_claimings)
return t
return $ M.fromList $ map (ticketComment . entityVal &&& id) ticket_entities
makeCommentRouteDB :: CommentId -> DB (Maybe (Route App))
makeCommentRouteDB comment_id = get comment_id >>= \case
Nothing -> return Nothing
......
......@@ -15,6 +15,8 @@ module Model.Project
, fetchProjectWikiEditsBeforeDB
, fetchProjectWikiPagesBeforeDB
, fetchProjectBlogPostsBeforeDB
, fetchProjectTicketClaimingsBeforeDB
, fetchProjectTicketUnclaimingsBeforeDB
, fetchProjectWikiPageByNameDB
, insertProjectPledgeDB
-- TODO(mitchell): rename all these... prefix fetch, suffix DB
......@@ -244,8 +246,7 @@ getProjectTagList project_id = (,) <$> getProjectTags <*> getOtherTags
-- | Get all of a Project's WikiPages, sorted alphabetically.
getProjectWikiPages :: ProjectId -> DB [Entity WikiPage]
getProjectWikiPages project_id =
select $
from $ \ wp -> do
select $ from $ \ wp -> do
where_ (exprWikiPageOnProject wp project_id)
orderBy [asc (wp ^. WikiPageTarget)]
return wp
......@@ -254,9 +255,7 @@ getProjectWikiPages project_id =
fetchProjectDiscussionsDB :: ProjectId -> DB [DiscussionId]
fetchProjectDiscussionsDB project_id = do
pd <- projectDiscussion <$> getJust project_id
wpds <- fmap (map unValue) $
select $
from $ \wp -> do
wpds <- fmap (map unValue) $ select $ from $ \wp -> do
where_ (wp ^. WikiPageProject ==. val project_id)
return (wp ^. WikiPageDiscussion)
return (pd : wpds)
......@@ -264,13 +263,11 @@ fetchProjectDiscussionsDB project_id = do
-- | 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
select $ from $ \(ecp `InnerJoin` c) -> do
on_ (ecp ^. EventCommentPostedComment ==. c ^. CommentId)
where_ $
ecp ^. EventCommentPostedTs <=. val before &&.
exprCommentProjectPermissionFilterIncludingRethreaded muser_id (val project_id) c &&.
c ^. CommentDiscussion `in_` valList project_discussions
where_ $ ecp ^. EventCommentPostedTs <=. val before
&&. exprCommentProjectPermissionFilterIncludingRethreaded muser_id (val project_id) c
&&. c ^. CommentDiscussion `in_` valList project_discussions
orderBy [ desc $ ecp ^. EventCommentPostedTs, desc $ ecp ^. EventCommentPostedId ]
limit lim
return c
......@@ -278,17 +275,42 @@ fetchProjectCommentsIncludingRethreadedBeforeDB 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 $ \(ecr `InnerJoin` r `InnerJoin` c) -> do
on_ (r ^. RethreadNewComment ==. c ^. CommentId)
on_ (ecr ^. EventCommentRethreadedRethread ==. r ^. RethreadId)
where_ $
ecr ^. EventCommentRethreadedTs <=. val before &&.
exprCommentProjectPermissionFilter muser_id (val project_id) c &&.
c ^. CommentDiscussion `in_` valList project_discussions
orderBy [ desc $ ecr ^. EventCommentRethreadedTs, desc $ ecr ^. EventCommentRethreadedId ]
limit lim
return r
select $ from $ \(ecr `InnerJoin` r `InnerJoin` c) -> do
on_ (r ^. RethreadNewComment ==. c ^. CommentId)
on_ (ecr ^. EventCommentRethreadedRethread ==. r ^. RethreadId)
where_ $ ecr ^. EventCommentRethreadedTs <=. val before
&&. exprCommentProjectPermissionFilter muser_id (val project_id) c
&&. c ^. CommentDiscussion `in_` valList project_discussions
orderBy [ desc $ ecr ^. EventCommentRethreadedTs, desc $ ecr ^. EventCommentRethreadedId ]
limit lim
return r
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
on_ (t ^. TicketComment ==. c ^. CommentId)
on_ (tc ^. TicketClaimingTicket ==. c ^. CommentId)
where_ $ tc ^. TicketClaimingTs <=. val before
&&. c ^. CommentDiscussion `in_` valList project_discussions
orderBy [ desc $ tc ^. TicketClaimingTs, desc $ tc ^. TicketClaimingId ]
limit lim
return tc
fetchProjectTicketUnclaimingsBeforeDB :: ProjectId -> UTCTime -> Int64 -> DB [Entity TicketClaiming]
fetchProjectTicketUnclaimingsBeforeDB project_id before lim = fetchProjectDiscussionsDB project_id >>= \project_discussions ->
select $ from $ \ (tc `InnerJoin` c `InnerJoin` t) -> do
on_ (t ^. TicketComment ==. c ^. CommentId)
on_ (tc ^. TicketClaimingTicket ==. c ^. CommentId)
where_ $ not_ (isNothing $ tc ^. TicketClaimingReleasedTs)
&&. tc ^. TicketClaimingReleasedTs <=. val (Just before)
&&. c ^. CommentDiscussion `in_` valList project_discussions
orderBy [ desc $ tc ^. TicketClaimingReleasedTs, desc $ tc ^. TicketClaimingId ]
limit lim
return tc
-- | Fetch all WikiPages made on this Project before this time.
fetchProjectWikiPagesBeforeDB :: ProjectId -> UTCTime -> Int64 -> DB [Entity WikiPage]
......
{-# LANGUAGE RecordWildCards #-}
module Model.SnowdriftEvent
( snowdriftEventNewestToOldest
, snowdriftEventTime
......@@ -17,27 +19,31 @@ snowdriftEventNewestToOldest :: SnowdriftEvent -> SnowdriftEvent -> Ordering
snowdriftEventNewestToOldest x y = compare (snowdriftEventTime y) (snowdriftEventTime x)
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
snowdriftEventTime (EBlogPost _ BlogPost{..}) = blogPostTs
snowdriftEventTime (ENewPledge _ SharesPledged{..}) = sharesPledgedTs
snowdriftEventTime (EUpdatedPledge _ _ SharesPledged{..}) = sharesPledgedTs
snowdriftEventTime (EDeletedPledge ts _ _ _) = ts
snowdriftEventTime (ECommentPosted _ Comment{..}) = fromMaybe commentCreatedTs commentApprovedTs
snowdriftEventTime (ECommentPending _ Comment{..}) = commentCreatedTs
snowdriftEventTime (ECommentRethreaded _ Rethread{..}) = rethreadTs
snowdriftEventTime (ETicketClaimed _ TicketClaiming{..}) = ticketClaimingTs
snowdriftEventTime (ETicketUnclaimed _ TicketClaiming{..}) = fromMaybe (error "TicketUnclaimed event for TicketClaiming with no ReleasedTs") ticketClaimingReleasedTs
snowdriftEventTime (ENotificationSent _ Notification{..}) = notificationCreatedTs
snowdriftEventTime (EWikiEdit _ WikiEdit{..}) = wikiEditTs
snowdriftEventTime (EWikiPage _ WikiPage{..}) = wikiPageCreatedTs
snowdriftEventTime (EBlogPost _ BlogPost{..}) = blogPostTs
snowdriftEventTime (ENewPledge _ SharesPledged{..}) = sharesPledgedTs
snowdriftEventTime (EUpdatedPledge _ _ SharesPledged{..}) = sharesPledgedTs
snowdriftEventTime (EDeletedPledge ts _ _ _) = ts
-- Eventually the html rendering here should be moved to the top level somewhere for sharing with notifications
snowdriftEventToFeedEntry
:: (Route App -> Text)
-> Text
-- -> Prefetch
-> Map UserId User
-> Map DiscussionId DiscussionOn
-> Map WikiPageId WikiPage
-> Map CommentId (Entity Ticket)
-> SnowdriftEvent
-> Maybe (FeedEntry (Route App))
snowdriftEventToFeedEntry render project_handle user_map discussion_map _ (ECommentPosted comment_id comment) =
snowdriftEventToFeedEntry render project_handle user_map discussion_map _ _ (ECommentPosted comment_id comment) =
let user_id = commentUser comment
maybe_user = M.lookup user_id user_map
username = maybe "<unknown user>" (userDisplayName . Entity user_id) maybe_user
......@@ -52,7 +58,7 @@ snowdriftEventToFeedEntry render project_handle user_map discussion_map _ (EComm
, feedEntryContent = [hamlet| |] render
}
snowdriftEventToFeedEntry render project_handle _ _ _ (ECommentRethreaded _ rethread) =
snowdriftEventToFeedEntry render project_handle _ _ _ _ (ECommentRethreaded _ rethread) =
Just $ FeedEntry
{ feedEntryLink = CommentDirectLinkR $ rethreadNewComment rethread
, feedEntryUpdated = rethreadTs rethread
......@@ -60,7 +66,47 @@ snowdriftEventToFeedEntry render project_handle _ _ _ (ECommentRethreaded _ reth
, feedEntryContent = [hamlet| |] render
}
snowdriftEventToFeedEntry render project_handle _ _ _ (EWikiPage _ wiki_page) =
snowdriftEventToFeedEntry render project_handle user_map _ _ ticket_map (ETicketClaimed _ TicketClaiming{..}) =
let user_id = ticketClaimingUser
maybe_user = M.lookup user_id user_map
username = maybe "<unknown user>" (userDisplayName . Entity user_id) maybe_user
Entity ticket_id Ticket{..} = lookupErr "snowdriftEventToFeedEntry: comment id not present in ticket map" ticketClaimingTicket ticket_map
ticket_str = case ticket_id of
Key (PersistInt64 tid) -> T.pack $ show tid
Key _ -> "<malformed id>"
in Just $ FeedEntry
{ feedEntryLink = CommentDirectLinkR ticketClaimingTicket
, feedEntryUpdated = ticketClaimingTs
, feedEntryTitle = T.unwords
[ T.snoc project_handle ':'
, "ticket claimed by"
, T.snoc username ':'
, T.concat [ "SD-", ticket_str, ":" ]
, ticketName
]
, feedEntryContent = [hamlet| |] render
}
snowdriftEventToFeedEntry render project_handle _ _ _ ticket_map (ETicketUnclaimed _ TicketClaiming{..}) =
let Entity ticket_id Ticket{..} = lookupErr "snowdriftEventToFeedEntry: comment id not present in ticket map" ticketClaimingTicket ticket_map
ticket_str = case ticket_id of
Key (PersistInt64 tid) -> T.pack $ show tid
Key _ -> "<malformed id>"
in Just $ FeedEntry
{ feedEntryLink = CommentDirectLinkR ticketClaimingTicket
, feedEntryUpdated = ticketClaimingTs
, feedEntryTitle = T.unwords
[ T.snoc project_handle ':'
, "ticket available:"
, T.concat [ "SD-", ticket_str, ":" ]
, ticketName
]
, feedEntryContent = [hamlet| |] render
}
snowdriftEventToFeedEntry render project_handle _ _ _ _ (EWikiPage _ wiki_page) =
let target = wikiPageTarget wiki_page
in Just $ FeedEntry
{ feedEntryLink = WikiR project_handle $ wikiPageTarget wiki_page
......@@ -69,7 +115,7 @@ snowdriftEventToFeedEntry render project_handle _ _ _ (EWikiPage _ wiki_page) =
, feedEntryContent = [hamlet| |] render
}
snowdriftEventToFeedEntry render project_handle user_map _ wiki_page_map (EWikiEdit wiki_edit_id wiki_edit) =
snowdriftEventToFeedEntry render project_handle user_map _ wiki_page_map _ (EWikiEdit wiki_edit_id wiki_edit) =
let maybe_wiki_page = M.lookup (wikiEditPage wiki_edit) wiki_page_map
target = maybe (error "missing wiki page for edit") wikiPageTarget maybe_wiki_page
user_id = wikiEditUser wiki_edit
......@@ -83,8 +129,8 @@ snowdriftEventToFeedEntry render project_handle user_map _ wiki_page_map (EWikiE
, feedEntryContent = [hamlet| |] render
}
snowdriftEventToFeedEntry render project_handle _ _ _
( EBlogPost _
snowdriftEventToFeedEntry render project_handle _ _ _ _
(EBlogPost _
BlogPost
{ blogPostHandle = handle
, blogPostTs = ts
......@@ -100,12 +146,12 @@ snowdriftEventToFeedEntry render project_handle _ _ _
-- We might want to show these, but I'm not sure. Leaving them out now, at any rate.
snowdriftEventToFeedEntry _ _ _ _ _ (ENewPledge _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ (EUpdatedPledge _ _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ (EDeletedPledge _ _ _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ (ENewPledge _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ (EUpdatedPledge _ _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ (EDeletedPledge _ _ _ _) = Nothing
-- Graveyard of event types we don't want to put on the feed.
-- Don't match-all here, we don't want to accidentally not consider something.
snowdriftEventToFeedEntry _ _ _ _ _ (ENotificationSent _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ (ECommentPending _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ (ENotificationSent _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ _ (ECommentPending _ _) = Nothing
......@@ -13,6 +13,10 @@ data SnowdriftEvent
= ECommentPosted CommentId Comment
-- Comment unapproved (pending approval).
| ECommentPending CommentId Comment
-- Ticket claimed
| ETicketClaimed TicketClaimingId TicketClaiming
-- Ticket unclaimed
| ETicketUnclaimed TicketClaimingId TicketClaiming
-- Comment rethreaded.
| ECommentRethreaded RethreadId Rethread -- rethreaded-from-URL
| ENotificationSent NotificationId Notification
......
......@@ -64,6 +64,7 @@ import Model.Wiki.Sql
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Control.Monad.Writer.Strict (tell)
import Yesod.Markdown (Markdown(..))
-- anonymousUser is a special user for items posted by visitors who are not
......@@ -390,14 +391,30 @@ userCanDeleteCommentDB user_id (Entity comment_id comment) =
then return True
else return False
-- TODO: claim event
userClaimCommentDB :: UserId -> CommentId -> Maybe Text -> DB ()
userClaimCommentDB user_id comment_id mnote = liftIO getCurrentTime >>= \now ->
insert_ (TicketClaiming now user_id comment_id mnote)
-- TODO: unclaim event
userUnclaimCommentDB :: UserId -> CommentId -> Maybe Text -> DB ()
userUnclaimCommentDB _ comment_id _ = deleteBy (UniqueTicketClaiming comment_id)
userClaimCommentDB :: UserId -> CommentId -> Maybe Text -> SDB ()
userClaimCommentDB user_id comment_id mnote = do
now <- liftIO getCurrentTime
let ticket_claiming = TicketClaiming now user_id comment_id mnote Nothing
ticket_claiming_id <- lift $ insert ticket_claiming
tell [ETicketClaimed ticket_claiming_id ticket_claiming]
userUnclaimCommentDB :: UserId -> CommentId -> Maybe Text -> SDB ()
userUnclaimCommentDB _ comment_id _ = do
maybe_ticket_claiming_entity <- getBy $ UniqueTicketClaiming comment_id
case maybe_ticket_claiming_entity of
Nothing -> return ()
Just (Entity ticket_claiming_id ticket_claiming) -> do
now <- liftIO getCurrentTime
lift $ update $ \ tc -> do
where_ $ tc ^. TicketClaimingId ==. val ticket_claiming_id
set tc [ TicketClaimingReleasedTs =. val (Just now) ]
tell [ ETicketUnclaimed ticket_claiming_id ticket_claiming { ticketClaimingReleasedTs = Just now } ]
-- | Fetch a User's number of unviewed comments on each WikiPage of a Project.
fetchNumUnviewedCommentsOnProjectWikiPagesDB :: UserId -> ProjectId -> DB (Map WikiPageId Int)
......
......@@ -93,6 +93,10 @@ notificationEventHandler (ECommentRethreaded _ Rethread{..}) = do
runSDB (sendNotificationDB_ NotifRethreadedComment (commentUser comment) Nothing content)
-- TODO: Send notification to anyone watching thread
notificationEventHandler (ETicketClaimed _ _) = return ()
notificationEventHandler (ETicketUnclaimed _ _) = return ()
notificationEventHandler (ENotificationSent _ _) = return ()
notificationEventHandler (EWikiEdit _ _) = return ()
notificationEventHandler (EWikiPage _ _) = return ()
......@@ -107,6 +111,12 @@ 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 (ETicketClaimed ticket_claiming_id TicketClaiming{..}) = runDB (insert_ (EventTicketClaimed ticketClaimingTs ticket_claiming_id))
eventInserterHandler (ETicketUnclaimed ticket_claiming_id TicketClaiming{..}) =
let released = fromMaybe (error "TicketUnclaimed event for TicketClaiming without ReleasedTs") ticketClaimingReleasedTs
in runDB (insert_ (EventTicketUnclaimed released ticket_claiming_id))
eventInserterHandler (ENotificationSent notif_id Notification{..}) = runDB (insert_ (EventNotificationSent notificationCreatedTs notif_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))
......
......@@ -13,6 +13,7 @@ import View.Comment
import Widgets.Time
import qualified Data.Map as M
import qualified Data.Text as T
renderCommentPostedEvent
:: CommentId
......@@ -129,6 +130,39 @@ renderCommentRethreadedEvent Rethread{..} user_map = do
: #{rethreadReason}
|]
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
Entity ticket_id Ticket{..} = lookupErr "renderTicketClaimedEvent: ticket not found in map" ticketClaimingTicket ticket_map
ticket_str = case ticket_id of
Key (PersistInt64 tid) -> T.pack $ show tid
Key _ -> "<malformed key>"
[whamlet|
<div .event>
^{renderTime ticketClaimingTs}
<a href=@{UserR ticketClaimingUser}> #{userDisplayName (Entity ticketClaimingUser user)}
claimed ticket
<a href=@{CommentDirectLinkR ticketClaimingTicket}>
<div .ticket-title>SD-#{ticket_str}: #{ticketName}
|]
renderTicketUnclaimedEvent :: TicketClaiming -> UserMap -> Map CommentId (Entity Ticket) -> Widget
renderTicketUnclaimedEvent TicketClaiming{..} _ ticket_map = do
let Entity ticket_id Ticket{..} = lookupErr "renderTicketClaimedEvent: ticket not found in map" ticketClaimingTicket ticket_map
ticket_str = case ticket_id of
Key (PersistInt64 tid) -> T.pack $ show tid
Key _ -> "<malformed key>"
[whamlet|
<div .event>
^{renderTime ticketClaimingTs}
Claim released, ticket available:
<a href=@{CommentDirectLinkR ticketClaimingTicket}>
<div .ticket-title>SD-#{ticket_str}: #{ticketName}
|]
renderWikiPageEvent :: Text -> WikiPageId -> WikiPage -> UserMap -> Widget
renderWikiPageEvent project_handle _ wiki_page _ = do
-- TODO(aaron)
......
......@@ -333,10 +333,11 @@ Ticket
deriving Eq Ord
TicketClaiming
ts UTCTime
user UserId
ticket CommentId
note Text Maybe
ts UTCTime
user UserId
ticket CommentId
note Text Maybe
releasedTs UTCTime Maybe
UniqueTicketClaiming ticket
......@@ -419,9 +420,17 @@ EventCommentPending
comment CommentId
EventCommentRethreaded
ts UTCTime
ts UTCTime
rethread RethreadId
EventTicketClaimed
ts UTCTime
claim TicketClaimingId
EventTicketUnclaimed
ts UTCTime
claim TicketClaimingId
-- Notification sent event.
EventNotificationSent
ts UTCTime
......
ALTER TABLE "ticket_claiming" ADD COLUMN "released_ts" TIMESTAMP NULL;
CREATe TABLE "event_ticket_claimed"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"claim" INT8 NOT NULL);
ALTER TABLE "event_ticket_claimed" ADD CONSTRAINT "event_ticket_claimed_claim_fkey" FOREIGN KEY("claim") REFERENCES "ticket_claiming"("id");
CREATe TABLE "event_ticket_unclaimed"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"claim" INT8 NOT NULL);
ALTER TABLE "event_ticket_unclaimed" ADD CONSTRAINT "event_ticket_unclaimed_claim_fkey" FOREIGN KEY("claim") REFERENCES "ticket_claiming"("id");
......@@ -8,6 +8,12 @@ $forall event <- events
$of ECommentRethreaded _ rethread
^{renderCommentRethreadedEvent rethread user_map}
$of ETicketClaimed _ claim
^{renderTicketClaimedEvent claim user_map ticket_map}
$of ETicketUnclaimed _ claim
^{renderTicketUnclaimedEvent claim user_map ticket_map}
$of EWikiPage wiki_page_id wiki_page
^{renderWikiPageEvent project_handle wiki_page_id wiki_page user_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