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

Commit 976d5e2c authored by Mitchell Rosen's avatar Mitchell Rosen

fixed bug in comment preview (inaccurate action permissions)

also some work on claim/unclaim HTML/CSS
parent 76e45860
This diff is collapsed.
......@@ -13,6 +13,7 @@ import Model.Application
import Model.Comment
import Model.Comment.ActionPermissions
import Model.Comment.HandlerInfo
import Model.Comment.Mods
import Model.Comment.Sql
import Model.Currency
import Model.Discussion
......@@ -116,8 +117,8 @@ checkProjectCommentActionPermission
project_handle
comment@(Entity comment_id _) = do
action_permissions <-
lookupErr "checkWikiPageCommentActionPermission: comment id not found in map" comment_id
<$> makeProjectCommentActionPermissionsMap (Just user) project_handle [comment]
lookupErr "checkProjectCommentActionPermission: comment id not found in map" comment_id
<$> makeProjectCommentActionPermissionsMap (Just user) project_handle def [comment]
unless (can_perform_action action_permissions)
(permissionDenied "You don't have permission to perform this action.")
......@@ -627,7 +628,7 @@ postReplyProjectCommentR project_handle parent_id = do
(Just parent_id)
user
(projectDiscussion project)
(makeProjectCommentActionPermissionsMap (Just user) project_handle) >>= \case
(makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
Left _ -> redirect (ProjectCommentR project_handle parent_id)
Right (widget, form) -> defaultLayout $ previewWidget form "post" (projectDiscussionPage project_handle widget)
......@@ -811,7 +812,7 @@ postNewProjectDiscussionR project_handle = do
Nothing
user
projectDiscussion
(makeProjectCommentActionPermissionsMap (Just user) project_handle) >>= \case
(makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
Left comment_id -> redirect (ProjectCommentR project_handle comment_id)
Right (widget, form) -> defaultLayout $ previewWidget form "post" (projectDiscussionPage project_handle widget)
......@@ -853,7 +854,7 @@ getProjectFeedR project_handle = do
(project, comments, rethreads, wiki_pages, wiki_edits, 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, flag_map) <- runYDB $ do
ticket_map, claim_map, flag_map) <- runYDB $ do
Entity project_id project <- getBy404 (UniqueProjectHandle project_handle)
......@@ -891,15 +892,16 @@ getProjectFeedR project_handle = do
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,
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,
flag_map)
claim_map, flag_map)
action_permissions_map <- makeProjectCommentActionPermissionsMap muser project_handle comments
action_permissions_map <- makeProjectCommentActionPermissionsMap muser project_handle def comments
let all_unsorted_events = mconcat
[ map (onEntity ECommentPosted) comments
......
......@@ -261,7 +261,7 @@ postNewWikiDiscussionR project_handle target = do
Nothing
user
wikiPageDiscussion
(makeProjectCommentActionPermissionsMap (Just user) project_handle) >>= \case
(makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
Left comment_id -> redirect (WikiCommentR project_handle target comment_id)
Right (widget, form) -> defaultLayout $ previewWidget form "post" ($(widgetFile "wiki_discussion_wrapper"))
......
......@@ -9,6 +9,7 @@ import Handler.Project (checkProjectCommentActionPermission)
import Model.Comment
import Model.Comment.ActionPermissions
import Model.Comment.HandlerInfo
import Model.Comment.Mods
import Model.Comment.Sql
import Model.User
import Widgets.Preview
......@@ -338,7 +339,7 @@ postReplyWikiCommentR project_handle target parent_id = do
(Just parent_id)
user
(wikiPageDiscussion page)
(makeProjectCommentActionPermissionsMap (Just user) project_handle) >>= \case
(makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
Left _ -> redirect (WikiCommentR project_handle target parent_id)
Right (widget, form) -> defaultLayout $ previewWidget form "post" (wikiDiscussionPage project_handle target widget)
......
module Model.Comment
-- Types
( CommentMods(..)
, MaxDepth(..)
( MaxDepth(..)
, NoCommentReason(..)
, addMaxDepth
-- Utility functions
......@@ -64,7 +63,6 @@ import Model.Utils
import qualified Control.Monad.State as State
import Control.Monad.Writer.Strict (tell)
import Data.Default (Default, def)
import Data.Foldable (Foldable)
import qualified Data.Foldable as F
import qualified Data.Map as M
......@@ -86,22 +84,6 @@ data NoCommentReason
= CommentNotFound
| CommentPermissionDenied
-- | Data type used in makeCommentWidgetMod, containing modifications to comment-action-related
-- data structures.
data CommentMods = CommentMods
{ mod_earlier_closures :: [CommentClosing] -> [CommentClosing]
, mod_earlier_retracts :: [CommentRetracting] -> [CommentRetracting]
, mod_user_map :: Map UserId User -> Map UserId User
, mod_closure_map :: Map CommentId CommentClosing -> Map CommentId CommentClosing
, mod_retract_map :: Map CommentId CommentRetracting -> Map CommentId CommentRetracting
, mod_ticket_map :: Map CommentId (Entity Ticket) -> Map CommentId (Entity Ticket)
, mod_flag_map :: Map CommentId (CommentFlagging, [FlagReason]) -> Map CommentId (CommentFlagging, [FlagReason])
, mod_tag_map :: Map TagId Tag -> Map TagId Tag
}
instance Default CommentMods where
def = CommentMods id id id id id id id id
data MaxDepth
= NoMaxDepth
| MaxDepth Int
......@@ -610,8 +592,8 @@ makeTicketMapDB comment_ids = fmap (foldr step mempty) $
where
step t = M.insert (ticketComment (entityVal t)) t
makeClaimedTicketMapDB :: [CommentId] -> DB (Map CommentId (Entity TicketClaiming))
makeClaimedTicketMapDB comment_ids = fmap (M.fromList . map (\(Value x, y) -> (x, y))) $
makeClaimedTicketMapDB :: [CommentId] -> DB (Map CommentId TicketClaiming)
makeClaimedTicketMapDB comment_ids = fmap (M.fromList . map (\(Value x, Entity _ y) -> (x, y))) $
select $
from $ \tc -> do
where_ (tc ^. TicketClaimingTicket `in_` valList comment_ids)
......
......@@ -8,6 +8,7 @@ module Model.Comment.ActionPermissions
import Import
import Model.Comment
import Model.Comment.Mods
import Model.User
import qualified Data.Map as M
......@@ -44,24 +45,24 @@ makeLoggedOutCommentActionPermissionsMap = return .
foldr (\(Entity comment_id _) -> M.insert comment_id loggedOutCommentActionPermissions) mempty
-- | Action permissions that apply to both a Project discussion and a Projects WikiPage discussion.
makeProjectCommentActionPermissionsMap :: Maybe (Entity User) -> Text -> MakeActionPermissionsMap
makeProjectCommentActionPermissionsMap Nothing _ comments = makeLoggedOutCommentActionPermissionsMap comments
makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_handle comments = do
makeProjectCommentActionPermissionsMap :: Maybe (Entity User) -> Text -> CommentMods -> MakeActionPermissionsMap
makeProjectCommentActionPermissionsMap Nothing _ _ comments = makeLoggedOutCommentActionPermissionsMap comments
makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_handle CommentMods{..} comments = do
let map2 :: (a -> b) -> (a -> c) -> [a] -> ([b],[c])
map2 f g = foldr (\a (bs, cs) -> (f a : bs, g a : cs)) ([],[])
(comment_ids, user_ids) = map2 entityKey (commentUser . entityVal) comments
(viewer_is_mod, user_map, claimed_map, closing_map, retracting_map, flag_map, ticket_map, comments_with_children) <- runYDB $ do
(viewer_is_mod, user_map, closing_map, retracting_map, ticket_map, claim_map, flag_map, comments_with_children) <- runYDB $ do
Entity project_id _ <- getBy404 (UniqueProjectHandle project_handle)
(,,,,,,,) <$> userIsProjectModeratorDB viewer_id project_id
<*> (entitiesMap <$> fetchUsersInDB user_ids)
<*> makeClaimedTicketMapDB comment_ids
<*> makeCommentClosingMapDB comment_ids
<*> makeCommentRetractingMapDB comment_ids
<*> makeFlagMapDB comment_ids
<*> makeTicketMapDB comment_ids
<*> (mod_user_map . entitiesMap <$> fetchUsersInDB user_ids)
<*> (mod_closure_map <$> makeCommentClosingMapDB comment_ids)
<*> (mod_retract_map <$> makeCommentRetractingMapDB comment_ids)
<*> (mod_ticket_map <$> makeTicketMapDB comment_ids)
<*> (mod_claim_map <$> makeClaimedTicketMapDB comment_ids)
<*> (mod_flag_map <$> makeFlagMapDB comment_ids)
<*> (S.fromList <$> fetchCommentsWithChildrenInDB comment_ids)
let viewer_is_established = userIsEstablished viewer
......@@ -76,7 +77,7 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
in M.insert comment_id (CommentActionPermissions
{ can_add_tag = viewer_is_established
, can_approve = viewer_is_mod && not (commentIsApproved comment)
, can_claim = M.member comment_id ticket_map && M.notMember comment_id claimed_map
, can_claim = M.member comment_id ticket_map && M.notMember comment_id claim_map
, can_close = viewer_can_close && M.notMember comment_id closing_map && commentIsApproved comment
, can_delete = viewer_id == user_id && S.notMember comment_id comments_with_children
, can_edit = userCanEditComment viewer_id comment
......@@ -86,8 +87,8 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
, can_rethread = viewer_is_mod || viewer_id == user_id
, can_retract = viewer_id == user_id && M.notMember comment_id retracting_map && commentIsApproved comment
, can_unclaim = maybe False
(\(Entity _ t) -> ticketClaimingUser t == viewer_id)
(M.lookup comment_id claimed_map)
(\t -> ticketClaimingUser t == viewer_id)
(M.lookup comment_id claim_map)
})
return (foldr step mempty comments)
......@@ -7,6 +7,7 @@ module Model.Comment.HandlerInfo
import Import
import Model.Comment.ActionPermissions
import Model.Comment.Mods
import Model.Comment.Routes
import Model.Comment.Sql
......@@ -20,16 +21,16 @@ data CommentHandlerInfo = CommentHandlerInfo
, commentHandlerMakeActionPermissionsMap :: MakeActionPermissionsMap
}
projectCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> CommentHandlerInfo
projectCommentHandlerInfo muser project_id project_handle =
projectCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> CommentMods -> CommentHandlerInfo
projectCommentHandlerInfo muser project_id project_handle mods =
CommentHandlerInfo
(exprCommentProjectPermissionFilter (entityKey <$> muser) (val project_id))
(projectCommentRoutes project_handle)
(makeProjectCommentActionPermissionsMap muser project_handle)
(makeProjectCommentActionPermissionsMap muser project_handle mods)
wikiPageCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> Text -> CommentHandlerInfo
wikiPageCommentHandlerInfo muser project_id project_handle target =
wikiPageCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> Text -> CommentMods -> CommentHandlerInfo
wikiPageCommentHandlerInfo muser project_id project_handle target mods =
CommentHandlerInfo
(exprCommentProjectPermissionFilter (entityKey <$> muser) (val project_id))
(wikiPageCommentRoutes project_handle target)
(makeProjectCommentActionPermissionsMap muser project_handle)
(makeProjectCommentActionPermissionsMap muser project_handle mods)
module Model.Comment.Mods where
import Import
import Data.Default (Default, def)
-- | Data type used in makeCommentWidgetMod, containing modifications to comment-action-related
-- data structures.
data CommentMods = CommentMods
{ mod_earlier_closures :: [CommentClosing] -> [CommentClosing]
, mod_earlier_retracts :: [CommentRetracting] -> [CommentRetracting]
, mod_user_map :: Map UserId User -> Map UserId User
, mod_closure_map :: Map CommentId CommentClosing -> Map CommentId CommentClosing
, mod_retract_map :: Map CommentId CommentRetracting -> Map CommentId CommentRetracting
, mod_ticket_map :: Map CommentId (Entity Ticket) -> Map CommentId (Entity Ticket)
, mod_claim_map :: Map CommentId TicketClaiming -> Map CommentId TicketClaiming
, mod_flag_map :: Map CommentId (CommentFlagging, [FlagReason]) -> Map CommentId (CommentFlagging, [FlagReason])
, mod_tag_map :: Map TagId Tag -> Map TagId Tag
}
instance Default CommentMods where
def = CommentMods id id id id id id id id id
......@@ -33,6 +33,7 @@ library
Model.Comment
Model.Comment.ActionPermissions
Model.Comment.HandlerInfo
Model.Comment.Mods
Model.Comment.Routes
Model.Comment.Sql
Model.Currency
......
......@@ -243,6 +243,7 @@ commentForestWidget
-> Map CommentId CommentClosing
-> Map CommentId CommentRetracting
-> Map CommentId (Entity Ticket)
-> Map CommentId TicketClaiming
-> Map CommentId (CommentFlagging, [FlagReason])
-> Bool -- ^ Is preview?
-> MaxDepth -- ^ Max depth.
......@@ -260,6 +261,7 @@ commentForestWidget
close_map
retract_map
ticket_map
claim_map
flag_map
is_preview
max_depth
......@@ -278,6 +280,7 @@ commentForestWidget
close_map
retract_map
ticket_map
claim_map
flag_map
is_preview
max_depth
......@@ -296,6 +299,7 @@ commentTreeWidget
-> Map CommentId CommentClosing
-> Map CommentId CommentRetracting
-> Map CommentId (Entity Ticket)
-> Map CommentId TicketClaiming
-> Map CommentId (CommentFlagging, [FlagReason])
-> Bool -- ^ Is preview?
-> MaxDepth
......@@ -317,6 +321,7 @@ commentTreeWidget'
-> Map CommentId CommentClosing
-> Map CommentId CommentRetracting
-> Map CommentId (Entity Ticket)
-> Map CommentId TicketClaiming
-> Map CommentId (CommentFlagging, [FlagReason])
-> Bool -- ^ Is preview?
-> MaxDepth
......@@ -334,6 +339,7 @@ commentTreeWidget'
close_map
retract_map
ticket_map
claim_map
flag_map
is_preview
max_depth
......@@ -357,6 +363,7 @@ commentTreeWidget'
close_map
retract_map
ticket_map
claim_map
flag_map
is_preview
max_depth
......@@ -374,6 +381,7 @@ commentTreeWidget'
(M.lookup root_id close_map)
(M.lookup root_id retract_map)
(M.lookup root_id ticket_map)
(M.lookup root_id claim_map)
(M.lookup root_id flag_map)
is_preview
inner_widget
......@@ -394,6 +402,7 @@ commentWidget :: Entity Comment -- ^ Comment.
-> Maybe CommentClosing -- ^ Is this closed?
-> Maybe CommentRetracting -- ^ Is this retracted?
-> Maybe (Entity Ticket) -- ^ Is this a ticket?
-> Maybe TicketClaiming -- ^ Is this ticket claimed?
-> Maybe (CommentFlagging, [FlagReason]) -- ^ Is this flagged?
-> Bool -- ^ Is this a preview?
-> Widget -- ^ Inner widget (children comments, 'expand' link, reply box, etc)
......@@ -408,6 +417,7 @@ commentWidget (Entity comment_id comment)
mclosure
mretract
mticket
mclaim
mflag
is_preview
inner_widget = do
......
......@@ -27,6 +27,7 @@ renderCommentPostedEvent
-> Map CommentId CommentClosing
-> Map CommentId CommentRetracting
-> Map CommentId (Entity Ticket)
-> Map CommentId TicketClaiming
-> Map CommentId (CommentFlagging, [FlagReason])
-> Widget
renderCommentPostedEvent
......@@ -42,6 +43,7 @@ renderCommentPostedEvent
closure_map
retract_map
ticket_map
claim_map
flag_map = do
let action_permissions = lookupErr "renderCommentPostedEvent: comment id missing from permissions map"
......@@ -89,6 +91,7 @@ renderCommentPostedEvent
(M.lookup comment_id closure_map)
(M.lookup comment_id retract_map)
(M.lookup comment_id ticket_map)
(M.lookup comment_id claim_map)
(M.lookup comment_id flag_map)
False
mempty
......
......@@ -339,6 +339,8 @@ TicketClaiming
UniqueTicketClaiming ticket
deriving Show
Build
bootTime UTCTime
base Text
......
......@@ -45,6 +45,9 @@
color : green
font-style : italic
.claimed-by
color : gray
.top_level
border-left : solid black 0.2em
......
......@@ -63,6 +63,29 @@
#{flag_markdown}
<i>Please edit to address these concerns and repost.
$maybe _ <- mticket
<span .glyphicon .glyphicon-tag>
$if can_claim
<div :is_preview:.preview .comment-action>
<a href="@{comment_route_claim comment_id}">
claim
$else
$maybe claim <- mclaim
<span .claimed-by>
claimed
^{renderTime (ticketClaimingTs claim)}
by
<a href="@{UserR user_id}">#{userDisplayName (Entity user_id user)}#
$maybe note <- ticketClaimingNote claim
: #{note}
$if can_unclaim
<div :is_preview:.preview .comment-action>
<a href="@{comment_route_unclaim comment_id}">
(unclaim)
$if is_unapproved
<div .awaiting-approval>
<span .glyphicon .glyphicon-arrow-right>
......@@ -80,16 +103,6 @@
^{tagWidget tag}
<div :is_preview:.preview .comment-actions>
$if can_claim
<div .comment-action>
<a href="@{comment_route_claim comment_id}">
claim
$if can_unclaim
<div .comment-action>
<a href="@{comment_route_unclaim comment_id}">
unclaim
$if can_edit
<div .comment-action>
<a href="@{comment_route_edit comment_id}">
......
......@@ -3,7 +3,7 @@
$forall event <- events
$case event
$of ECommentPosted comment_id comment
^{renderCommentPostedEvent comment_id comment muser_id project_handle discussion_map action_permissions_map earlier_closures_map earlier_retracts_map user_map closure_map retract_map ticket_map flag_map}
^{renderCommentPostedEvent comment_id comment muser_id project_handle discussion_map action_permissions_map earlier_closures_map earlier_retracts_map user_map closure_map retract_map ticket_map claim_map flag_map}
$of ECommentRethreaded _ rethread
^{renderCommentRethreadedEvent rethread 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