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

Commit 7a37eae4 authored by Mitchell Rosen's avatar Mitchell Rosen

split CommentClosure into CommentClosing and CommentRetracting

parent 66d93b74
......@@ -66,10 +66,14 @@ import Yesod.Default.Config (appRoot)
--------------------------------------------------------------------------------
-- Utility functions
earlierClosuresFromMaybeParentId :: Maybe CommentId -> Handler [CommentClosure]
earlierClosuresFromMaybeParentId :: Maybe CommentId -> Handler [CommentClosing]
earlierClosuresFromMaybeParentId Nothing = return []
earlierClosuresFromMaybeParentId (Just c) = runDB (fetchCommentAncestorClosuresDB' c)
earlierRetractsFromMaybeParentId :: Maybe CommentId -> Handler [CommentRetracting]
earlierRetractsFromMaybeParentId Nothing = return []
earlierRetractsFromMaybeParentId (Just c) = runDB (fetchCommentAncestorRetractsDB' c)
-- | Get the max depth from the "maxdepth" GET param, or 11 (arbitrary) if it doesn't exist.
getMaxDepth :: Handler MaxDepth
getMaxDepth = getMaxDepthDefault 11
......@@ -107,19 +111,23 @@ makeCommentForestWidget
is_preview
form_under_root_comment = do
let root_ids = map entityKey roots
(children, user_map, earlier_closures_map, closure_map, ticket_map, flag_map) <- runDB $ do
(children, user_map, earlier_closures_map, earlier_retracts_map,
closure_map, retract_map, ticket_map, flag_map) <- runDB $ do
children <- fetchCommentsDescendantsDB root_ids commentHandlerHasPermission
let all_comments = roots ++ children
all_comment_ids = map entityKey all_comments
earlier_closures_map <- fetchCommentsAncestorClosuresDB root_ids
earlier_retracts_map <- fetchCommentsAncestorRetractsDB root_ids
user_map <- entitiesMap <$> fetchUsersInDB (S.toList $ makeCommentUsersSet all_comments)
closure_map <- makeClosureMapDB all_comment_ids
ticket_map <- makeTicketMapDB all_comment_ids
flag_map <- makeFlagMapDB all_comment_ids
closure_map <- makeCommentClosingMapDB all_comment_ids
retract_map <- makeCommentRetractingMapDB all_comment_ids
ticket_map <- makeTicketMapDB all_comment_ids
flag_map <- makeFlagMapDB all_comment_ids
return (children, user_map, earlier_closures_map, closure_map, ticket_map, flag_map)
return (children, user_map, earlier_closures_map, earlier_retracts_map,
closure_map, retract_map, ticket_map, flag_map)
max_depth <- get_max_depth
......@@ -129,6 +137,7 @@ makeCommentForestWidget
forM_ comment_forest $ \comment_tree -> do
let root_id = entityKey (rootLabel comment_tree)
earlier_closures = M.findWithDefault [] root_id earlier_closures_map
earlier_retracts = M.findWithDefault [] root_id earlier_retracts_map
commentTreeWidget
comment_tree
......@@ -136,8 +145,10 @@ makeCommentForestWidget
commentHandlerRoutes
commentHandlerMakeActionPermissionsMap
(mod_earlier_closures earlier_closures)
(mod_earlier_retracts earlier_retracts)
(mod_user_map user_map_with_viewer)
(mod_closure_map closure_map)
(mod_retract_map retract_map)
(mod_ticket_map ticket_map)
(mod_flag_map flag_map)
is_preview
......@@ -282,47 +293,34 @@ postClaimComment user@(Entity user_id _) comment_id comment comment_handler_info
return (Just (comment_widget, form))
_ -> error "Error when submitting form."
postCloseComment, postRetractComment :: Entity User -> CommentId -> Comment -> CommentHandlerInfo -> Handler (Maybe (Widget, Widget))
postCloseComment = postClosureComment closeCommentForm newClosedCommentClosure can_close
postRetractComment = postClosureComment retractCommentForm newRetractedCommentClosure can_retract
-- | Handle a POST to a /close or /retract URL.
-- | Handle a POST to a /close URL.
-- Permission checking should occur *PRIOR TO* this function.
postClosureComment
:: (Maybe Markdown -> Form NewClosure)
-> (UserId -> Markdown -> CommentId -> Handler CommentClosure)
-> (CommentActionPermissions -> Bool)
-> Entity User
postCloseComment
:: Entity User
-> CommentId
-> Comment
-> CommentHandlerInfo
-> Handler (Maybe (Widget, Widget))
postClosureComment
make_closure_form
make_new_comment_closure
can_perform_action
user@(Entity user_id _)
comment_id
comment
comment_handler_info = do
((result, _), _) <- runFormPost (make_closure_form Nothing)
postCloseComment user@(Entity user_id _) comment_id comment comment_handler_info = do
((result, _), _) <- runFormPost (closeCommentForm Nothing)
case result of
FormSuccess (NewClosure reason) -> do
new_comment_closure <- make_new_comment_closure user_id reason comment_id
now <- liftIO getCurrentTime
let closing = CommentClosing now user_id reason comment_id
lookupPostMode >>= \case
Just PostMode -> do
runDB (insert_ new_comment_closure)
runDB (insert_ closing)
return Nothing
_ -> do
(form, _) <- generateFormPost (make_closure_form (Just reason))
(form, _) <- generateFormPost (closeCommentForm (Just reason))
(comment_widget, _) <-
makeCommentActionWidget
can_perform_action
can_close
mempty
(Entity comment_id comment)
user
comment_handler_info
(def { mod_closure_map = M.insert comment_id new_comment_closure })
(def { mod_closure_map = M.insert comment_id closing })
(getMaxDepthDefault 0)
True
......@@ -413,6 +411,8 @@ postFlagComment user@(Entity user_id _) comment@(Entity comment_id _) comment_ha
^{form}
|]
now <- liftIO getCurrentTime
let flagging = CommentFlagging now user_id comment_id message
(comment_widget, _) <-
makeCommentActionWidget
can_flag
......@@ -420,7 +420,7 @@ postFlagComment user@(Entity user_id _) comment@(Entity comment_id _) comment_ha
comment
user
comment_handler_info
(def { mod_flag_map = M.insert comment_id (message, reasons) })
(def { mod_flag_map = M.insert comment_id (flagging, reasons) })
(getMaxDepthDefault 0)
True
return (Just (style_widget <> previewWidget form_with_header "flag comment" comment_widget))
......@@ -457,6 +457,7 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m
return (Left comment_id)
_ -> do
earlier_closures <- earlierClosuresFromMaybeParentId mparent_id
earlier_retracts <- earlierRetractsFromMaybeParentId mparent_id
depth <- runDB (fetchCommentDepthFromMaybeParentIdDB mparent_id)
(form, _) <- generateFormPost (commentForm (maybe "New Topic" (const "Reply") mparent_id) (Just contents))
now <- liftIO getCurrentTime
......@@ -477,8 +478,10 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m
dummyCommentRoutes -- 'True' below, so routes aren't used.
make_permissions_map
earlier_closures
earlier_retracts
(M.singleton user_id user)
mempty -- closure map
mempty -- retract map
mempty -- ticket map - TODO(mitchell): this isn't right... if *this* comment is a ticket, we should display it as such.
mempty -- flag map
True
......@@ -558,6 +561,40 @@ postRethreadComment user_id comment_id comment = do
_ -> error "no preview for rethreads yet" -- TODO(david)
_ -> error "Error when submitting form."
-- | Handle a POST to a /close URL.
-- Permission checking should occur *PRIOR TO* this function.
postRetractComment
:: Entity User
-> CommentId
-> Comment
-> CommentHandlerInfo
-> Handler (Maybe (Widget, Widget))
postRetractComment user@(Entity user_id _) comment_id comment comment_handler_info = do
((result, _), _) <- runFormPost (retractCommentForm Nothing)
case result of
FormSuccess (NewClosure reason) -> do
now <- liftIO getCurrentTime
let retracting = CommentRetracting now reason comment_id
lookupPostMode >>= \case
Just PostMode -> do
runDB (insert_ retracting)
return Nothing
_ -> do
(form, _) <- generateFormPost (retractCommentForm (Just reason))
(comment_widget, _) <-
makeCommentActionWidget
can_retract
mempty
(Entity comment_id comment)
user
comment_handler_info
(def { mod_retract_map = M.insert comment_id retracting })
(getMaxDepthDefault 0)
True
return (Just (comment_widget, form))
_ -> error "Error when submitting form."
getCommentTags :: CommentId -> Handler Html
getCommentTags comment_id = do
muser_id <- maybeAuthId
......
......@@ -9,6 +9,6 @@ import Model.Discussion
-- "root comment getter", by looking for a "state=open" or "state=closed" GET param.
getDiscussion :: ((DiscussionId -> ExprCommentCond -> DB [Entity Comment]) -> Handler Html) -> Handler Html
getDiscussion callback = lookupGetParam "state" >>= \case
Just "closed" -> callback fetchDiscussionClosedRootCommentsDB
Just "closed" -> callback fetchDiscussionClosedOrRetractedRootCommentsDB
-- Not "closed"? Just accept anything else as meaning "open".
_ -> callback fetchDiscussionRootCommentsDB
......@@ -852,7 +852,8 @@ 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, closure_map, ticket_map, flag_map) <- runYDB $ do
earlier_closures_map, earlier_retracts_map, closure_map, retract_map,
ticket_map, flag_map) <- runYDB $ do
Entity project_id project <- getBy404 (UniqueProjectHandle project_handle)
......@@ -886,14 +887,17 @@ getProjectFeedR project_handle = do
user_map <- entitiesMap <$> fetchUsersInDB user_ids
earlier_closures_map <- fetchCommentsAncestorClosuresDB comment_ids
closure_map <- makeClosureMapDB comment_ids
ticket_map <- makeTicketMapDB comment_ids
flag_map <- makeFlagMapDB comment_ids
earlier_retracts_map <- fetchCommentsAncestorRetractsDB comment_ids
closure_map <- makeCommentClosingMapDB comment_ids
retract_map <- makeCommentRetractingMapDB comment_ids
ticket_map <- makeTicketMapDB 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, closure_map,
ticket_map, flag_map)
wiki_page_map, user_map, earlier_closures_map,
earlier_retracts_map, closure_map, retract_map, ticket_map,
flag_map)
action_permissions_map <- makeProjectCommentActionPermissionsMap muser project_handle comments
......
......@@ -2,7 +2,7 @@
module Model where
import Model.Comment.Internal (ClosureType, FlagReason, Visibility)
import Model.Comment.Internal (FlagReason, Visibility)
import Model.Currency (Milray)
import Model.Established.Internal (Established(..))
import Model.Markdown.Diff (MarkdownDiff)
......
......@@ -7,12 +7,14 @@ import Model.CollapseState.Internal
import Data.Time.Units
collapseState :: UTCTime -> CommentClosure -> Handler CollapseState
collapseState now closure =
return $ case (fromIntegral :: Integer -> Second) $ round $ diffUTCTime now $ commentClosureTs closure of
-- TODO: make these user preference
x | convertUnit x < (24 :: Hour) -> FullyVisible
x | convertUnit x < (72 :: Hour) -> Collapsed
_ -> FullyHidden
collapseState :: Handler ()
collapseState = undefined -- TODO(mitchell, david)
-- collapseState :: UTCTime -> CommentClosure -> Handler CollapseState
-- collapseState now closure =
-- return $ case (fromIntegral :: Integer -> Second) $ round $ diffUTCTime now $ commentClosureTs closure of
-- -- TODO: make these user preference
-- x | convertUnit x < (24 :: Hour) -> FullyVisible
-- x | convertUnit x < (72 :: Hour) -> Collapsed
-- _ -> FullyHidden
module Model.Comment
-- Types
( ClosureMap
, CommentMods(..)
, FlagMap
( CommentMods(..)
, MaxDepth(..)
, NoCommentReason(..)
, TicketMap
, addMaxDepth
-- Utility functions
, buildCommentForest
......@@ -17,16 +14,17 @@ module Model.Comment
, commentIsTopLevel
, makeCommentUsersSet
, makeApprovedComment
, newClosedCommentClosure
, newRetractedCommentClosure
-- Database actions
, approveCommentDB
, deleteCommentDB
, editCommentDB
, flagCommentDB
, fetchCommentAncestorClosuresDB
, fetchCommentAncestorRetractsDB
, fetchCommentAncestorClosuresDB'
, fetchCommentAncestorRetractsDB'
, fetchCommentsAncestorClosuresDB
, fetchCommentsAncestorRetractsDB
, fetchCommentDB
, fetchCommentAllDescendantsDB
, fetchCommentAncestorsDB
......@@ -46,7 +44,8 @@ module Model.Comment
, fetchCommentsWithChildrenInDB
, filterCommentsDB
, makeClaimedTicketMapDB
, makeClosureMapDB
, makeCommentClosingMapDB
, makeCommentRetractingMapDB
, makeCommentRouteDB
, makeFlagMapDB
, makeTicketMapDB
......@@ -61,31 +60,27 @@ import Import
import Model.Comment.Sql
import Model.Discussion
import Model.Notification
import Model.Tag
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
import Data.Maybe (fromJust)
import qualified Data.Set as S
import qualified Data.Text as T
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
import Data.Maybe (fromJust)
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Tree
import qualified Database.Persist as P
import GHC.Exts (IsList(..))
import qualified Prelude as Prelude
import Yesod.Markdown (Markdown(..))
import Database.Esqueleto.Internal.Language (Insertion)
import qualified Database.Persist as P
import GHC.Exts (IsList(..))
import qualified Prelude as Prelude
import Yesod.Markdown (Markdown(..))
--------------------------------------------------------------------------------
-- Types
type ClosureMap = Map CommentId CommentClosure
type TicketMap = Map CommentId (Entity Ticket)
type FlagMap = Map CommentId (Maybe Markdown, [FlagReason])
-- | A root comment (with its own URL) might not be displayed. Why?
data NoCommentReason
= CommentNotFound
......@@ -94,16 +89,18 @@ data NoCommentReason
-- | Data type used in makeCommentWidgetMod, containing modifications to comment-action-related
-- data structures.
data CommentMods = CommentMods
{ mod_earlier_closures :: [CommentClosure] -> [CommentClosure]
, mod_user_map :: Map UserId User -> Map UserId User
, mod_closure_map :: ClosureMap -> ClosureMap
, mod_ticket_map :: TicketMap -> TicketMap
, mod_flag_map :: FlagMap -> FlagMap
, mod_tag_map :: TagMap -> TagMap
{ 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 Ticket -> Map CommentId 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
def = CommentMods id id id id id id id id
data MaxDepth
= NoMaxDepth
......@@ -172,13 +169,13 @@ buildCommentForest :: [Entity Comment] -- root comments
-> Forest (Entity Comment)
buildCommentForest roots replies = (map (flip buildCommentTree replies)) roots
newClosedCommentClosure, newRetractedCommentClosure :: MonadIO m => UserId -> Markdown -> CommentId -> m CommentClosure
newClosedCommentClosure = newCommentClosure Closed
newRetractedCommentClosure = newCommentClosure Retracted
-- newClosedCommentClosure, newRetractedCommentClosure :: MonadIO m => UserId -> Markdown -> CommentId -> m CommentClosure
-- newClosedCommentClosure = newCommentClosure Closed
-- newRetractedCommentClosure = newCommentClosure Retracted
newCommentClosure :: MonadIO m => ClosureType -> UserId -> Markdown -> CommentId -> m CommentClosure
newCommentClosure closure_type user_id reason comment_id =
(\now -> CommentClosure now user_id closure_type reason comment_id) `liftM` liftIO getCurrentTime
-- newCommentClosure :: MonadIO m => ClosureType -> UserId -> Markdown -> CommentId -> m CommentClosure
-- newCommentClosure closure_type user_id reason comment_id =
-- (\now -> CommentClosure now user_id closure_type reason comment_id) `liftM` liftIO getCurrentTime
-- | Construct a comment, auto-approved by 'this' User (because they are established).
makeApprovedComment :: MonadIO m => UserId -> DiscussionId -> Maybe CommentId -> Markdown -> Int -> Visibility -> m Comment
......@@ -416,39 +413,56 @@ filterCommentsDB comment_ids has_permission = fmap (map unValue) $
has_permission c
return (c ^. CommentId)
-- | Get all ancestors that have been closed.
fetchCommentAncestorClosuresDB :: CommentId -> DB [CommentClosure]
fetchCommentAncestorClosuresDB comment_id = fmap (map entityVal) $
-- | Get all ancestors that have been closed/retracted.
fetchCommentAncestorClosuresDB :: CommentId -> DB [CommentClosing]
fetchCommentAncestorRetractsDB :: CommentId -> DB [CommentRetracting]
fetchCommentAncestorClosuresDB = commentClosuresOrRetracts CommentClosingComment
fetchCommentAncestorRetractsDB = commentClosuresOrRetracts CommentRetractingComment
commentClosuresOrRetracts :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
=> (EntityField val CommentId) -> CommentId -> DB [val]
commentClosuresOrRetracts comment_field comment_id = fmap (map entityVal) $
select $
from $ \(ca `InnerJoin` cc) -> do
on_ (ca ^. CommentAncestorAncestor ==. cc ^. CommentClosureComment)
orderBy [asc (cc ^. CommentClosureComment)]
from $ \(ca `InnerJoin` table) -> do
on_ (ca ^. CommentAncestorAncestor ==. table ^. comment_field)
orderBy [asc (table ^. comment_field)]
where_ (ca ^. CommentAncestorComment ==. val comment_id)
return cc
return table
-- | Get all ancestors, including this comment, that have been closed.
fetchCommentAncestorClosuresDB' :: CommentId -> DB [CommentClosure]
fetchCommentAncestorClosuresDB' comment_id = do
-- | Get all ancestors, including this comment, that have been closed/retracted.
fetchCommentAncestorClosuresDB' :: CommentId -> DB [CommentClosing]
fetchCommentAncestorRetractsDB' :: CommentId -> DB [CommentRetracting]
fetchCommentAncestorClosuresDB' = commentClosuresOrRetracts' CommentClosingComment
fetchCommentAncestorRetractsDB' = commentClosuresOrRetracts' CommentRetractingComment
commentClosuresOrRetracts' :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
=> (EntityField val CommentId) -> CommentId -> DB [val]
commentClosuresOrRetracts' comment_field comment_id = do
all_comment_ids <- (comment_id :) <$> fetchCommentAncestorsDB comment_id
fmap (map entityVal) $
select $
from $ \cc -> do
where_ (cc ^. CommentClosureComment `in_` valList all_comment_ids)
return cc
from $ \table -> do
where_ (table ^. comment_field `in_` valList all_comment_ids)
return table
-- | Get all CommentClosures of any of the given Comments' ancestors, grouped by
-- | Get all CommentClosings/CommentRetracts of any of the given Comments' ancestors, grouped by
-- the given Comments.
fetchCommentsAncestorClosuresDB :: [CommentId] -> DB (Map CommentId [CommentClosure])
fetchCommentsAncestorClosuresDB comment_ids = fmap (foldr step mempty) $
fetchCommentsAncestorClosuresDB :: [CommentId] -> DB (Map CommentId [CommentClosing])
fetchCommentsAncestorRetractsDB :: [CommentId] -> DB (Map CommentId [CommentRetracting])
fetchCommentsAncestorClosuresDB = commentsClosuresOrRetracts CommentClosingComment
fetchCommentsAncestorRetractsDB = commentsClosuresOrRetracts CommentRetractingComment
commentsClosuresOrRetracts :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
=> EntityField val CommentId -> [CommentId] -> DB (Map CommentId [val])
commentsClosuresOrRetracts comment_field comment_ids = fmap (foldr step mempty) $
select $
from $ \(ca `InnerJoin` cc) -> do
on_ (ca ^. CommentAncestorAncestor ==. cc ^. CommentClosureComment)
orderBy [asc (cc ^. CommentClosureComment)]
from $ \(ca `InnerJoin` table) -> do
on_ (ca ^. CommentAncestorAncestor ==. table ^. comment_field)
orderBy [asc (table ^. comment_field)]
where_ (ca ^. CommentAncestorComment `in_` valList comment_ids)
return (ca ^. CommentAncestorComment, cc)
return (ca ^. CommentAncestorComment, table)
where
step :: (Value CommentId, Entity CommentClosure) -> Map CommentId [CommentClosure] -> Map CommentId [CommentClosure]
step (Value c, Entity _ cc) = M.insertWith (++) c [cc]
step (Value c, Entity _ v) = M.insertWith (++) c [v]
-- | Get a comment's ancestors' ids.
fetchCommentAncestorsDB :: CommentId -> DB [CommentId]
......@@ -565,21 +579,36 @@ fetchCommentTagCommentTagsDB comment_id tag_id = fmap (map entityVal) $
ct ^. CommentTagTag ==. val tag_id
return ct
makeClosureMapDB :: (IsList c, CommentId ~ Item c) => c -> DB ClosureMap
makeClosureMapDB comment_ids = fmap (M.fromList . map ((commentClosureComment &&& id) . entityVal)) $
makeCommentClosingMapDB :: (IsList c, CommentId ~ Item c) => c -> DB (Map CommentId CommentClosing)
makeCommentRetractingMapDB :: (IsList c, CommentId ~ Item c) => c -> DB (Map CommentId CommentRetracting)
makeCommentClosingMapDB = closeOrRetractMap CommentClosingComment commentClosingComment
makeCommentRetractingMapDB = closeOrRetractMap CommentRetractingComment commentRetractingComment
closeOrRetractMap
:: (IsList c, CommentId ~ Item c, PersistEntity val, PersistEntityBackend val ~ SqlBackend)
=> EntityField val CommentId
-> (val -> CommentId)
-> c
-> DB (Map CommentId val)
closeOrRetractMap comment_field comment_projection comment_ids = fmap (foldr step mempty) $
select $
from $ \c -> do
where_ (c ^. CommentClosureComment `in_` valList comment_ids)
where_ (c ^. comment_field `in_` valList comment_ids)
return c
where
-- step :: Entity val -> Map CommentId val -> Map CommentId val
step (Entity _ c) = M.insert (comment_projection c) c
-- | Given a collection of CommentId, make a map from CommentId to Entity Ticket. Comments that
-- are not tickets will simply not be in the map.
makeTicketMapDB :: (IsList c, CommentId ~ Item c) => c -> DB TicketMap
makeTicketMapDB comment_ids = fmap (M.fromList . map ((ticketComment . entityVal) &&& id)) $
makeTicketMapDB :: (IsList c, CommentId ~ Item c) => c -> DB (Map CommentId Ticket)
makeTicketMapDB comment_ids = fmap (foldr step mempty) $
select $
from $ \t -> do
where_ (t ^. TicketComment `in_` valList comment_ids)
return t
where
step (Entity _ t) = M.insert (ticketComment t) t
makeClaimedTicketMapDB :: [CommentId] -> DB (Map CommentId (Entity TicketClaiming))
makeClaimedTicketMapDB comment_ids = fmap (M.fromList . map (\(Value x, y) -> (x, y))) $
......@@ -588,24 +617,21 @@ makeClaimedTicketMapDB comment_ids = fmap (M.fromList . map (\(Value x, y) -> (x
where_ (tc ^. TicketClaimingTicket `in_` valList comment_ids)
return (tc ^. TicketClaimingTicket, tc)
-- | Given a collection of CommentId, make a FlagMap. Comments that are not flagged
-- | Given a collection of CommentId, make a flag map. Comments that are not flagged
-- will simply not be in the map.
makeFlagMapDB :: (IsList c, CommentId ~ Item c) => c -> DB FlagMap
makeFlagMapDB comment_ids = mkFlagMap <$> getCommentFlaggings
makeFlagMapDB :: (IsList c, CommentId ~ Item c) => c -> DB (Map CommentId (CommentFlagging, [FlagReason]))
makeFlagMapDB comment_ids = fmap (go . map (\(Entity _ x, Value y) -> (x, y))) $
select $
from $ \(cf `InnerJoin` cfr) -> do
on_ (cf ^. CommentFlaggingId ==. cfr ^. CommentFlaggingReasonFlagging)
where_ (cf ^. CommentFlaggingComment `in_` valList comment_ids)
return (cf, cfr ^. CommentFlaggingReasonReason)
where
getCommentFlaggings :: DB [(CommentId, Maybe Markdown, FlagReason)]
getCommentFlaggings = fmap (map unwrapValues) $
select $
from $ \(cf `InnerJoin` cfr) -> do
on_ (cf ^. CommentFlaggingId ==. cfr ^. CommentFlaggingReasonFlagging)
where_ (cf ^. CommentFlaggingComment `in_` valList comment_ids)
return (cf ^. CommentFlaggingComment, cf ^. CommentFlaggingMessage, cfr ^. CommentFlaggingReasonReason)
mkFlagMap :: [(CommentId, Maybe Markdown, FlagReason)] -> FlagMap
mkFlagMap = foldr (\(comment_id, message, reason) -> M.insertWith combine comment_id (message, [reason])) mempty
go :: [(CommentFlagging, FlagReason)] -> Map CommentId (CommentFlagging, [FlagReason])
go = foldr (\(cf@(CommentFlagging _ _ comment_id _), reason) -> M.insertWith combine comment_id (cf, [reason])) mempty
where
combine :: (Maybe Markdown, [FlagReason]) -> (Maybe Markdown, [FlagReason]) -> (Maybe Markdown, [FlagReason])
combine (message, reasons1) (_, reasons2) = (message, reasons1 <> reasons2)
combine :: (CommentFlagging, [FlagReason]) -> (CommentFlagging, [FlagReason]) -> (CommentFlagging, [FlagReason])
combine (cf, reasons1) (_, reasons2) = (cf, reasons1 <> reasons2)
rethreadCommentDB :: Maybe CommentId -> DiscussionId -> CommentId -> UserId -> Text -> Int -> SDB ()
rethreadCommentDB mnew_parent_id new_discussion_id root_comment_id user_id reason depth_offset = do
......
......@@ -52,16 +52,17 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
(comment_ids, user_ids) = map2 entityKey (commentUser . entityVal) comments
(viewer_is_mod, user_map, claimed_map, closure_map, flag_map, ticket_map, comments_with_children) <- runYDB $ do
(viewer_is_mod, user_map, claimed_map, closing_map, retracting_map, flag_map, ticket_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
<*> makeClosureMapDB comment_ids
<*> makeFlagMapDB comment_ids
<*> makeTicketMapDB comment_ids
<*> (S.fromList <$> fetchCommentsWithChildrenInDB comment_ids)
(,,,,,,,) <$> userIsProjectModeratorDB viewer_id project_id
<*> (entitiesMap <$> fetchUsersInDB user_ids)
<*> makeClaimedTicketMapDB comment_ids
<*> makeCommentClosingMapDB comment_ids
<*> makeCommentRetractingMapDB comment_ids
<*> makeFlagMapDB comment_ids
<*> makeTicketMapDB comment_ids
<*> (S.fromList <$> fetchCommentsWithChildrenInDB comment_ids)
let viewer_is_established = userIsEstablished viewer
viewer_can_close = userCanCloseComment viewer
......@@ -76,14 +77,14 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
{ 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_close = viewer_can_close && M.notMember comment_id closure_map && commentIsApproved comment
, 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
, can_establish = viewer_is_mod && userIsUnestablished user
, can_flag = viewer_is_established && viewer_id /= user_id && M.notMember comment_id flag_map
, can_reply = commentIsApproved comment
, can_rethread = viewer_is_mod || viewer_id == user_id
, can_retract = viewer_id == user_id && commentIsApproved comment
, 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)
......
......@@ -7,12 +7,6 @@ import Data.Text (Text)
import Yesod.Markdown (Markdown)
data ClosureType
= Retracted
| Closed
deriving (Read, Show)
derivePersistField "ClosureType"
-- VisPublic = visible to all | VisPrivate = visible to topic-poster and
-- those with provenance over the discussion (e.g. project team for project
-- discussion ) | VisInternal = visible only to those with provenance over
......
module Model.Comment.Sql where
module Model.Comment.Sql
( ExprCommentCond
, exprCommentApproved
, exprCommentClosedOrRetracted
, exprCommentFlagged
, exprCommentIsRoot
, exprCommentNotRethreaded