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

Commit e9fdcb27 authored by Mitchell Rosen's avatar Mitchell Rosen

only show open tickets on /t; fix bug in project comment sql code

parent cbf3efc2
......@@ -47,8 +47,8 @@ import Model.Comment.ActionPermissions
import Model.Comment.HandlerInfo
import Model.Comment.Routes
import Model.Project
import Model.Tag
import Model.User
import Model.Tag
import View.Comment
import Widgets.Preview
import Widgets.Tag
......
......@@ -1070,7 +1070,7 @@ getTicketsR project_handle = do
muser_id <- maybeAuthId
(project, tagged_tickets) <- runYDB $ do
Entity project_id project <- getBy404 (UniqueProjectHandle project_handle)
tagged_tickets <- fetchProjectTaggedTicketsDB project_id muser_id
tagged_tickets <- fetchProjectOpenTicketsDB project_id muser_id
return (project, tagged_tickets)
((result, formWidget), encType) <- runFormGet viewForm
......
......@@ -38,10 +38,10 @@ module Model.Comment
, fetchCommentDescendantsDB
, fetchCommentDestinationDB
, fetchCommentFlaggingDB
, fetchCommentsDescendantsDB
, fetchCommentRethreadDB
, fetchCommentTagsDB
, fetchCommentTagCommentTagsDB
, fetchCommentsDescendantsDB
, fetchCommentsInDB
, fetchCommentsWithChildrenInDB
, filterCommentsDB
......
......@@ -3,15 +3,13 @@ module Model.Project
, UpdateProject(..)
, fetchAllProjectsDB
, fetchProjectCommentRethreadsBeforeDB
, fetchProjectCommentsDB
, fetchProjectCommentsIncludingRethreadedBeforeDB
, fetchProjectDeletedPledgesBeforeDB
, fetchProjectDiscussionsDB
, fetchProjectNewPledgesBeforeDB
, fetchProjectModeratorsDB
, fetchProjectTeamMembersDB
, fetchProjectTicketsDB
, fetchProjectTaggedTicketsDB
, fetchProjectOpenTicketsDB
, fetchProjectUpdatedPledgesBeforeDB
, fetchProjectVolunteerApplicationsDB
, fetchProjectWikiEditsBeforeDB
......@@ -32,17 +30,15 @@ module Model.Project
import Import
import Data.Filter
import Data.Order
import Model.Comment
import Model.Comment.Sql
import Model.Currency
import Model.Issue
import Model.Project.Sql
import Model.Tag
import Model.User
import Model.Wiki.Sql
import Widgets.Tag
import Data.Filter
import Data.Order
import Model.Comment
import Model.Comment.Sql
import Model.Currency
import Model.Issue
import Model.Tag
import Model.Wiki.Sql
import Widgets.Tag
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Control.Monad.Trans.Resource (MonadThrow)
......@@ -113,10 +109,6 @@ ticketToOrderable (TaggedTicket ((Entity _ ticket),tags)) = Orderable has_tag ge
--------------------------------------------------------------------------------
-- Database actions
-- | Fetch all Comments made on this Project, somewhere.
fetchProjectCommentsDB :: ProjectId -> Maybe UserId -> DB [CommentId]
fetchProjectCommentsDB project_id muser_id = fmap (map unValue) $ select (querProjectCommentsDB project_id muser_id)
fetchAllProjectsDB :: DB [Entity Project]
fetchAllProjectsDB = select (from return)
......@@ -387,18 +379,19 @@ fetchProjectWikiPageByNameDB project_handle target = runMaybeT $ do
Entity project_id _ <- MaybeT (getBy (UniqueProjectHandle project_handle))
MaybeT (getBy (UniqueWikiTarget project_id target))
fetchProjectTicketsDB :: ProjectId -> Maybe UserId -> DB [Entity Ticket]
fetchProjectTicketsDB project_id muser_id =
select $
from $ \(t `InnerJoin` c) -> do
on_ (t ^. TicketComment ==. c ^. CommentId)
where_ (c ^. CommentId `in_` subList_select (querProjectCommentsDB project_id muser_id))
return t
fetchProjectTaggedTicketsDB :: ProjectId -> Maybe UserId -> DB [TaggedTicket]
fetchProjectTaggedTicketsDB project_id muser_id = do
tickets <- fetchProjectTicketsDB project_id muser_id
fetchProjectOpenTicketsDB :: ProjectId -> Maybe UserId -> DB [TaggedTicket]
fetchProjectOpenTicketsDB project_id muser_id = do
tickets <- fetchProjectDiscussionsDB project_id >>= fetch_tickets
annot_tags_map <- fetchCommentCommentTagsInDB (map (ticketComment . entityVal) tickets) >>= buildAnnotatedCommentTagsDB muser_id
let tagTicket :: Entity Ticket -> TaggedTicket
tagTicket t@(Entity _ ticket) = TaggedTicket (t, M.findWithDefault [] (ticketComment ticket) annot_tags_map)
return (map tagTicket tickets)
where
fetch_tickets discussion_ids =
select $
from $ \(t `InnerJoin` c) -> do
on_ (t ^. TicketComment ==. c ^. CommentId)
where_ $
c ^. CommentDiscussion `in_` valList discussion_ids &&.
c ^. CommentId `notIn` exprClosedCommentIds
return t
......@@ -2,25 +2,8 @@ module Model.Project.Sql where
import Import
import Model.Comment.Sql
import Model.Wiki.Sql
querProjectCommentsDB :: ProjectId -> Maybe UserId -> SqlQuery (SqlExpr (Value CommentId))
querProjectCommentsDB project_id muser_id =
from $ \c -> do
-- Add more locations for Comments here as necessary.
where_ (c ^. CommentId `in_` subList_select (querProjectCommentsOnWikiPagesDB project_id muser_id))
return (c ^. CommentId)
querProjectCommentsOnWikiPagesDB :: ProjectId -> Maybe UserId -> SqlQuery (SqlExpr (Value CommentId))
querProjectCommentsOnWikiPagesDB project_id muser_id =
from $ \(c `InnerJoin` wp) -> do
on_ (exprCommentOnWikiPage c wp)
where_ $
exprWikiPageOnProject wp project_id &&.
exprCommentProjectPermissionFilter muser_id (val project_id) c
return (c ^. CommentId)
-- | Query that returns all WikiEdits made on any WikiPage on this Project
querProjectWikiEdits :: ProjectId -> SqlQuery (SqlExpr (Value WikiEditId))
querProjectWikiEdits project_id =
......
......@@ -5,6 +5,7 @@ module Model.Tag
, annotTagScore
, annotTagScoreString
, annotTagUserScore
, buildAnnotatedCommentTagsDB
, sortAnnotTagsByName
, sortAnnotTagsByScore
, fetchAllTagsDB
......@@ -78,3 +79,47 @@ sortAnnotTagsByName = sortBy (compare `on` annotTagName)
sortAnnotTagsByScore :: [AnnotatedTag] -> [AnnotatedTag]
sortAnnotTagsByScore = sortBy (compare `on` annotTagScore)
-- | Annotate a [CommentTag]. Returns a Map CommentId [AnnotatedTag] so this
-- function can be called with multiple Comments' CommentTags. If all
-- [CommentTag] are of the same comment, that's fine -- the returned map will
-- only have one key.
--
-- The [AnnotatedTag] value is left unsorted, but the [(Entity User, Int)] within each
-- AnnotatedTag is sorted by ascending username.
buildAnnotatedCommentTagsDB :: Maybe UserId -> [CommentTag] -> DB (Map CommentId [AnnotatedTag])
buildAnnotatedCommentTagsDB muser_id comment_tags = do
let user_ids = map commentTagUser comment_tags
user_map <- entitiesMap <$> selectList [UserId <-. user_ids] []
tag_map <- entitiesMap <$> fetchTagsInDB (map commentTagTag comment_tags)
-- TODO(mitchell): cached
tag_colors <- maybe fetchDefaultTagColorsDB fetchTagColorsDB muser_id
let f :: [CommentTag] -> Map CommentId [AnnotatedTag]
f = M.mapWithKey (map . i) . M.map h . g
-- Pair each CommentTag with its CommentId, then collect CommentTags back up,
-- grouped by their CommentIds.
g :: [CommentTag] -> Map CommentId [CommentTag]
g = M.fromListWith (++) . map (commentTagComment &&& return)
-- Group each CommentTag by TagId, combining Users' votes.
h :: [CommentTag] -> [(TagId, [(Entity User, Int)])]
h = M.toList . foldr step mempty
where
step :: CommentTag -> Map TagId [(Entity User, Int)] -> Map TagId [(Entity User, Int)]
step (CommentTag _ tag_id user_id n) =
M.insertWith (++) tag_id [(Entity user_id (user_map M.! user_id), n)]
-- Construct an AnnotatedTag given all relevant info.
i :: CommentId -> (TagId, [(Entity User, Int)]) -> AnnotatedTag
i comment_id (tag_id, user_votes) =
AnnotatedTag
(Entity tag_id (tag_map M.! tag_id))
(CommentTagR comment_id tag_id)
(M.findWithDefault 0x77AADD tag_id tag_colors)
(sortBy (compare `on` (userName . entityVal . fst)) user_votes)
return (f comment_tags)
......@@ -13,7 +13,6 @@ module Model.User
, userIsUnestablished
, userDisplayName
-- Database actions
, buildAnnotatedCommentTagsDB
, eligEstablishUserDB
, establishUserDB
, fetchAllUserRolesDB
......@@ -54,13 +53,12 @@ import Import
import Model.Comment
import Model.Comment.Sql
import Model.Notification
import Model.Project
import Model.Project.Sql
import Model.Tag
import Model.User.Internal
import Model.User.Sql
import Model.Wiki.Sql
import Data.List (sortBy)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
......@@ -311,10 +309,11 @@ userUnwatchProjectDB user_id project_id = do
delete_comment_views = delete_wiki_page_comment_views
delete_wiki_page_comment_views =
delete_wiki_page_comment_views = fetchProjectDiscussionsDB project_id >>= \discussion_ids ->
delete $
from $ \vc ->
where_ (vc ^. ViewCommentComment `in_` subList_select (querProjectCommentsOnWikiPagesDB project_id (Just user_id)))
from $ \(vc `InnerJoin` c) -> do
on_ (vc ^. ViewCommentComment ==. c ^. CommentId)
where_ (c ^. CommentDiscussion `in_` valList discussion_ids)
delete_wiki_edit_views =
delete $
......@@ -425,44 +424,3 @@ fetchNumUnreadNotificationsDB user_id = fmap (\[Value n] -> n) $
u ^. UserId ==. val user_id &&.
n ^. NotificationCreatedTs >=. u ^. UserReadNotifications
return countRows
-- | Annotate a [CommentTag]. Returns a Map CommentId [AnnotatedTag] so this
-- function can be called with multiple Comments' CommentTags. If all
-- [CommentTag] are of the same comment, that's fine -- the returned map will
-- only have one key.
--
-- The [AnnotatedTag] value is left unsorted, but the [(Entity User, Int)] within each
-- AnnotatedTag is sorted by ascending username.
buildAnnotatedCommentTagsDB :: Maybe UserId -> [CommentTag] -> DB (Map CommentId [AnnotatedTag])
buildAnnotatedCommentTagsDB muser_id comment_tags = do
user_map <- entitiesMap <$> fetchUsersInDB (map commentTagUser comment_tags)
tag_map <- entitiesMap <$> fetchTagsInDB (map commentTagTag comment_tags)
-- TODO(mitchell): cached
tag_colors <- maybe fetchDefaultTagColorsDB fetchTagColorsDB muser_id
let f :: [CommentTag] -> Map CommentId [AnnotatedTag]
f = M.mapWithKey (map . i) . M.map h . g
-- Pair each CommentTag with its CommentId, then collect CommentTags back up,
-- grouped by their CommentIds.
g :: [CommentTag] -> Map CommentId [CommentTag]
g = M.fromListWith (++) . map (commentTagComment &&& return)
-- Group each CommentTag by TagId, combining Users' votes.
h :: [CommentTag] -> [(TagId, [(Entity User, Int)])]
h = M.toList . foldr step mempty
where
step :: CommentTag -> Map TagId [(Entity User, Int)] -> Map TagId [(Entity User, Int)]
step (CommentTag _ tag_id user_id n) =
M.insertWith (++) tag_id [(Entity user_id (user_map M.! user_id), n)]
-- Construct an AnnotatedTag given all relevant info.
i :: CommentId -> (TagId, [(Entity User, Int)]) -> AnnotatedTag
i comment_id (tag_id, user_votes) =
AnnotatedTag
(Entity tag_id (tag_map M.! tag_id))
(CommentTagR comment_id tag_id)
(M.findWithDefault 0x77AADD tag_id tag_colors)
(sortBy (compare `on` (userName . entityVal . fst)) user_votes)
return (f comment_tags)
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