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

Commit f5448a1e authored by Mitchell Rosen's avatar Mitchell Rosen

rethread notifications and project feed events

parent ab6967d3
......@@ -481,74 +481,52 @@ postRethreadComment user_id comment_id comment = do
-- FIXME(mitchell,david): We shouldn't have to enumerate the routes like this.
-- Luckily robust rethreading is not priority.
(new_parent_id, new_discussion_id) <- case parseRoute (url, []) of
Just (WikiCommentR new_project_handle new_target new_parent_id) -> do
(new_route, mnew_parent_id, new_discussion_id) <- case parseRoute (url, []) of
Just (new_route@(WikiCommentR new_project_handle new_target new_parent_id)) -> do
new_discussion_id <-
maybe notfound (wikiPageDiscussion . entityVal) <$>
runDB (fetchProjectWikiPageByNameDB new_project_handle new_target)
return (Just new_parent_id, new_discussion_id)
Just (WikiDiscussionR new_project_handle new_target) -> do
return (new_route, Just new_parent_id, new_discussion_id)
Just (new_route@(WikiDiscussionR new_project_handle new_target)) -> do
new_discussion_id <-
maybe notfound (wikiPageDiscussion . entityVal) <$>
runDB (fetchProjectWikiPageByNameDB new_project_handle new_target)
return (Nothing, new_discussion_id)
Just (ProjectCommentR new_project_handle new_parent_id) -> do
return (new_route, Nothing, new_discussion_id)
Just (new_route@(ProjectCommentR new_project_handle new_parent_id)) -> do
new_discussion_id <-
maybe notfound (projectDiscussion . entityVal) <$>
runDB (getBy (UniqueProjectHandle new_project_handle))
return (Just new_parent_id, new_discussion_id)
Just (ProjectDiscussionR new_project_handle) -> do
return (new_route, Just new_parent_id, new_discussion_id)
Just (new_route@(ProjectDiscussionR new_project_handle)) -> do
new_discussion_id <-
maybe notfound (projectDiscussion . entityVal) <$>
runDB (getBy (UniqueProjectHandle new_project_handle))
return (Nothing, new_discussion_id)
return (new_route, Nothing, new_discussion_id)
Nothing -> error "failed to parse URL"
_ -> notfound
let old_parent_id = commentParent comment
when (new_parent_id == old_parent_id && new_discussion_id == commentDiscussion comment) $
error "trying to move comment to its current location"
let mold_parent_id = commentParent comment
when (mnew_parent_id == mold_parent_id && new_discussion_id == commentDiscussion comment) $ do
alertDanger "trying to move comment to its current location"
getCommentDirectLinkR comment_id
new_parent_depth <- maybe (return $ -1) fetchCommentDepth404DB new_parent_id
old_parent_depth <- maybe (return $ -1) fetchCommentDepth404DB old_parent_id
let depth_offset = old_parent_depth - new_parent_depth
new_parent_depth <- maybe (return (-1)) fetchCommentDepth404DB mnew_parent_id
old_parent_depth <- maybe (return (-1)) fetchCommentDepth404DB mold_parent_id
lookupPostMode >>= \case
Just PostMode -> do
now <- liftIO getCurrentTime
runDB $ do
descendants <- fetchCommentAllDescendantsDB comment_id
rethread_id <- insert (Rethread now user_id comment_id reason)
let comments = comment_id : descendants
new_comment_ids <- rethreadCommentsDB rethread_id depth_offset new_parent_id new_discussion_id comments
delete $
from $ \ca ->
where_ $ ca ^. CommentAncestorComment `in_` valList comments
forM_ new_comment_ids $ \ new_comment_id -> do
insertSelect $
from $ \(c `InnerJoin` ca) -> do
on_ (c ^. CommentParent ==. just (ca ^. CommentAncestorComment))
where_ (c ^. CommentId ==. val new_comment_id)
return (CommentAncestor <# val new_comment_id <&> (ca ^. CommentAncestorAncestor))
[Value maybe_new_parent_id] <-
select $
from $ \c -> do
where_ (c ^. CommentId ==. val new_comment_id)
return (c ^. CommentParent)
maybe (return ()) (insert_ . CommentAncestor new_comment_id) maybe_new_parent_id
when (new_discussion_id /= commentDiscussion comment) $
update $ \c -> do
set c [ CommentDiscussion =. val new_discussion_id ]
where_ (c ^. CommentId `in_` valList descendants)
runSDB $
rethreadCommentDB
mnew_parent_id
new_discussion_id
comment_id
user_id
reason
(old_parent_depth - new_parent_depth)
new_route_text <- getUrlRender <*> pure new_route
alertSuccess ("comment rethreaded to " <> new_route_text)
redirect new_parent_url
_ -> error "no preview for rethreads yet" -- TODO(david)
......@@ -629,14 +607,8 @@ postCommentCreateTag comment_id = do
--------------------------------------------------------------------------------
-- /
getCommentDirectLinkR :: CommentId -> Handler Html
getCommentDirectLinkR comment_id = runDB (fetchCommentWikiPageDB comment_id) >>= \case
-- comment not on a wiki page? right now, there's nowhere else to check
-- TODO(mitchell): does this require constant attention?
Nothing -> notFound
Just (Entity _ page) -> do
project <- runYDB (get404 (wikiPageProject page))
redirect (WikiCommentR (projectHandle project) (wikiPageTarget page) comment_id)
getCommentDirectLinkR :: CommentId -> Handler ()
getCommentDirectLinkR comment_id = runDB (makeCommentRouteDB comment_id) >>= maybe notFound redirect
deleteCommentDirectLinkR :: CommentId -> Handler ()
deleteCommentDirectLinkR comment_id = do
......
......@@ -33,6 +33,7 @@ import Widgets.Preview
import Widgets.Time
import Data.Default (def)
import qualified Data.Foldable as F
import Data.List (sortBy)
import qualified Data.Map as M
import Data.Maybe (maybeToList)
......@@ -802,52 +803,45 @@ getEditProjectR project_handle = do
-- statically guarantees that.
getProjectFeedR :: Text -> Handler Html
getProjectFeedR project_handle = do
let lim = 26 -- limit n from each table, then take (n-1)
let lim = 26 -- limit 'lim' from each table, then take 'lim - 1'
muser <- maybeAuth
let muser_id = entityKey <$> muser
before <- lookupGetUTCTimeDefaultNow "before"
(project, comment_entities, wiki_pages, wiki_edit_entities,
new_pledges, updated_pledges, deleted_pledges,
discussion_wiki_page_map, wiki_page_map, user_map,
(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
Entity project_id project <- getBy404 (UniqueProjectHandle project_handle)
project_comments <- fetchProjectCommentsBeforeDB project_id muser_id before lim
wiki_page_comments <- fetchProjectWikiPageCommentsBeforeDB project_id muser_id before lim
wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim
wiki_edit_entities <- fetchProjectWikiEditsBeforeDB project_id before lim
new_pledges <- fetchProjectNewPledgesBeforeDB project_id before lim
updated_pledges <- fetchProjectUpdatedPledgesBeforeDB project_id before lim
deleted_pledges <- fetchProjectDeletedPledgesBeforeDB project_id before lim
comments <- fetchProjectCommentsIncludingRethreadedBeforeDB project_id muser_id before lim
rethreads <- fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim
wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim
wiki_edits <- fetchProjectWikiEditsBeforeDB project_id before lim
new_pledges <- fetchProjectNewPledgesBeforeDB project_id before lim
updated_pledges <- fetchProjectUpdatedPledgesBeforeDB project_id before lim
deleted_pledges <- fetchProjectDeletedPledgesBeforeDB project_id before lim
-- Suplementary maps for displaying the data. If something above requires extra
-- data to display the project feed row, it MUST be used to fetch the data below!
-- The Maybes from Data.Map.lookup are unsafely STRIPPED in the views!
let comment_entities = project_comments <> wiki_page_comments
comment_ids = map entityKey comment_entities
comments = map entityVal comment_entities
wiki_edits = map entityVal wiki_edit_entities
shares_pledged = map entityVal (new_pledges <> (map snd updated_pledges))
-- All users: Comment posters, WikiPage creators, WikiEdit makers,
-- and Pledgers (new, updated, and deleted).
let (comment_ids, comment_users) = F.foldMap (\c -> ([entityKey c], [commentUser (entityVal c)])) comments
(wiki_edit_users, wiki_edit_pages) = F.foldMap (\(Entity _ e) -> ([wikiEditUser e], [wikiEditPage e])) wiki_edits
shares_pledged = map entityVal (new_pledges <> (map snd updated_pledges))
-- All users: comment posters, wiki page creators, etc.
user_ids = S.toList $
S.fromList (map commentUser comments) <>
S.fromList (map wikiEditUser wiki_edits) <>
S.fromList comment_users <>
S.fromList (map (rethreadModerator . entityVal) rethreads) <>
S.fromList wiki_edit_users <>
S.fromList (map sharesPledgedUser shares_pledged) <>
S.fromList (map eventDeletedPledgeUser deleted_pledges)
-- WikiPages that can be keyed by a Comment's DiscussionId (i.e. the Comment *is* on a WikiPage)
discussion_wiki_page_map <- M.fromList . map (\e@(Entity _ WikiPage{..}) -> (wikiPageDiscussion, e)) <$>
fetchDiscussionWikiPagesInDB (map commentDiscussion comments)
discussion_map <- fetchProjectDiscussionsDB project_id >>= fetchDiscussionsDB
-- WikiPages keyed by their own IDs (contained in a WikiEdit)
wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB (map wikiEditPage wiki_edits)
wiki_page_map <- entitiesMap <$> fetchWikiPagesInDB wiki_edit_pages
user_map <- entitiesMap <$> fetchUsersInDB user_ids
......@@ -856,21 +850,21 @@ getProjectFeedR project_handle = do
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)
return (project, comment_entities, wiki_pages, wiki_edit_entities,
new_pledges, updated_pledges, deleted_pledges,
discussion_wiki_page_map, wiki_page_map, user_map,
earlier_closures_map, closure_map, ticket_map, flag_map)
action_permissions_map <- makeProjectCommentActionPermissionsMap muser project_handle comment_entities
action_permissions_map <- makeProjectCommentActionPermissionsMap muser project_handle comments
let all_unsorted_events = mconcat
[ map (onEntity ECommentPosted) comment_entities
, map (onEntity EWikiPage) wiki_pages
, map (onEntity EWikiEdit) wiki_edit_entities
, map (onEntity ENewPledge) new_pledges
, map eup2se updated_pledges
, map edp2se deleted_pledges
[ map (onEntity ECommentPosted) comments
, map (onEntity ECommentRethreaded) rethreads
, map (onEntity EWikiPage) wiki_pages
, map (onEntity EWikiEdit) wiki_edits
, map (onEntity ENewPledge) new_pledges
, map eup2se updated_pledges
, map edp2se deleted_pledges
]
(events, more_events) = splitAt (lim-1) (sortBy snowdriftEventNewestToOldest all_unsorted_events)
......@@ -887,11 +881,11 @@ getProjectFeedR project_handle = do
$(widgetFile "project_feed")
toWidget $(cassiusFile "templates/comment.cassius")
where
-- "event updated pledge to snowdrift event". Makes above code cleaner.
-- "event updated pledge to snowdrift event"
eup2se :: (Int64, Entity SharesPledged) -> SnowdriftEvent
eup2se (old_shares, Entity shares_pledged_id shares_pledged) = EUpdatedPledge old_shares shares_pledged_id shares_pledged
-- "event deleted pledge to snowdrift event". Makes above code cleaner.
-- "event deleted pledge to snowdrift event"
edp2se :: EventDeletedPledge -> SnowdriftEvent
edp2se (EventDeletedPledge a b c d) = EDeletedPledge a b c d
......
......@@ -2,7 +2,12 @@ module Handler.Utils where
import Import
import qualified Data.Text as T
import Blaze.ByteString.Builder (Builder, toLazyByteString)
import Control.Monad.Reader (MonadReader, ask)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Yesod (renderRoute)
-- | Possible values for "mode" post param.
data PostMode
......@@ -23,3 +28,12 @@ lookupGetUTCTimeDefaultNow name = lookupGetParam name >>= \case
Just value -> case reads (T.unpack value) of
[(time,"")] -> return time
_ -> liftIO getCurrentTime
routeToText :: MonadReader App m => Route App -> m Text
routeToText route = do
app <- ask
let (path_pieces, query_params) = renderRoute route
return (b2t (joinPath app "" path_pieces query_params))
where
b2t :: Builder -> Text
b2t = TL.toStrict . TLE.decodeUtf8 . toLazyByteString
......@@ -238,6 +238,10 @@ getByErr message = runYDB . fmap fromJustError . getBy
lookupErr :: Ord k => String -> k -> Map k a -> a
lookupErr = M.findWithDefault . error
fromJustErr :: String -> Maybe a -> a
fromJustErr _ (Just x) = x
fromJustErr msg _ = error msg
class WrappedValues a where
type Unwrapped a
unwrapValues :: a -> Unwrapped a
......
......@@ -39,41 +39,41 @@ module Model.Comment
, fetchCommentDestinationDB
, fetchCommentFlaggingDB
, fetchCommentsDescendantsDB
, fetchCommentWikiPageDB
, fetchCommentRethreadDB
, fetchCommentTagsDB
, fetchCommentTagCommentTagsDB
, fetchCommentsInDB
, fetchCommentsWithChildrenInDB
, filterCommentsDB
, makeClosureMapDB
, makeCommentRouteDB
, makeFlagMapDB
, makeTicketMapDB
, postApprovedCommentDB
, postUnapprovedCommentDB
, rethreadCommentsDB
, rethreadCommentDB
, subFetchCommentAncestorsDB
, unsafeFetchCommentPageDB
, unsafeFetchCommentPageIdDB
) where
import Import
import Model.Comment.Sql
import Model.Discussion
import Model.Notification
import Model.Tag
import qualified Control.Monad.State as St
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(..))
--------------------------------------------------------------------------------
......@@ -308,6 +308,15 @@ fetchCommentDB comment_id has_permission = get comment_id >>= \case
has_permission c
return c
fetchCommentsInDB :: [CommentId] -> ExprCommentCond -> DB [Entity Comment]
fetchCommentsInDB comment_ids has_permission =
select $
from $ \c -> do
where_ $
c ^. CommentId `in_` valList comment_ids &&.
has_permission c
return c
-- | Delete-cascade a comment from the database.
deleteCommentDB :: CommentId -> DB ()
deleteCommentDB = deleteCascade
......@@ -460,24 +469,6 @@ fetchCommentDepth404DB = fmap commentDepth . runYDB . get404
fetchCommentFlaggingDB :: CommentId -> DB (Maybe (Entity CommentFlagging))
fetchCommentFlaggingDB = getBy . UniqueCommentFlagging
unsafeFetchCommentPageDB :: CommentId -> DB WikiPage
unsafeFetchCommentPageDB = fmap entityVal . unsafeFetchCommentPageEntityDB
unsafeFetchCommentPageIdDB :: CommentId -> DB WikiPageId
unsafeFetchCommentPageIdDB = fmap entityKey . unsafeFetchCommentPageEntityDB
-- | Fails if the given Comment is not on a WikiPage, but some other Discussion.
unsafeFetchCommentPageEntityDB :: CommentId -> DB (Entity WikiPage)
unsafeFetchCommentPageEntityDB = fmap fromJust . fetchCommentWikiPageDB
fetchCommentWikiPageDB :: CommentId -> DB (Maybe (Entity WikiPage))
fetchCommentWikiPageDB comment_id = fmap listToMaybe $
select $
from $ \(c `InnerJoin` p) -> do
on_ (c ^. CommentDiscussion ==. p ^. WikiPageDiscussion)
where_ (c ^. CommentId ==. val comment_id)
return p
-- | Get the CommentId this CommentId was rethreaded to, if it was.
fetchCommentRethreadDB :: CommentId -> DB (Maybe CommentId)
fetchCommentRethreadDB comment_id = fmap unValue . listToMaybe <$> (
......@@ -503,7 +494,12 @@ fetchCommentCommentTagsInDB comment_ids = fmap (map entityVal) $
-- | Get a Comment's descendants' ids (don't filter hidden or unapproved comments).
fetchCommentAllDescendantsDB :: CommentId -> DB [CommentId]
fetchCommentAllDescendantsDB = fmap (map unValue) . select . querCommentDescendants
fetchCommentAllDescendantsDB comment_id = fmap (map unValue) $
select $
from $ \ca -> do
where_ (ca ^. CommentAncestorAncestor ==. val comment_id)
orderBy [asc (ca ^. CommentAncestorComment)]
return (ca ^. CommentAncestorComment)
-- | Get all descendants of the given root comment.
fetchCommentDescendantsDB :: CommentId -> ExprCommentCond -> DB [Entity Comment]
......@@ -511,8 +507,11 @@ fetchCommentDescendantsDB comment_id has_permission =
select $
from $ \c -> do
where_ $
c ^. CommentId `in_` subList_select (querCommentDescendants comment_id) &&.
has_permission c
has_permission c &&.
c ^. CommentId `in_` (subList_select $
from $ \ca -> do
where_ (ca ^. CommentAncestorAncestor ==. val comment_id)
return (ca ^. CommentAncestorComment))
-- DO NOT change ordering here! buildCommentTree relies on it.
orderBy [asc (c ^. CommentParent), asc (c ^. CommentCreatedTs)]
return c
......@@ -599,44 +598,85 @@ makeFlagMapDB comment_ids = mkFlagMap <$> getCommentFlaggings
combine :: (Maybe Markdown, [FlagReason]) -> (Maybe Markdown, [FlagReason]) -> (Maybe Markdown, [FlagReason])
combine (message, reasons1) (_, reasons2) = (message, reasons1 <> reasons2)
rethreadCommentsDB :: RethreadId -> Int -> Maybe CommentId -> DiscussionId -> [CommentId] -> DB [CommentId]
rethreadCommentsDB rethread_id depth_offset maybe_new_parent_id new_discussion_id comment_ids = do
new_comment_ids <- flip St.evalStateT M.empty $ forM comment_ids $ \ comment_id -> do
rethreads <- St.get
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
(old_comment_ids, new_comment_ids) <- lift $ do
descendants_ids <- fetchCommentAllDescendantsDB root_comment_id
let old_comment_ids = root_comment_id : descendants_ids
Just comment <- get comment_id
new_comment_ids <- flip State.evalStateT mempty $ forM old_comment_ids $ \comment_id -> do
rethread_map <- State.get
let new_parent_id = maybe maybe_new_parent_id Just $ M.lookup (commentParent comment) rethreads
Just comment <- get comment_id
new_comment_id <- insert $ comment
{ commentDepth = commentDepth comment - depth_offset
, commentParent = new_parent_id
, commentDiscussion = new_discussion_id
}
let new_parent_id = maybe mnew_parent_id Just $ M.lookup (commentParent comment) rethread_map
St.put $ M.insert (Just comment_id) new_comment_id rethreads
new_comment_id <- insert $ comment
{ commentDepth = commentDepth comment - depth_offset
, commentParent = new_parent_id
, commentDiscussion = new_discussion_id
}
return new_comment_id
State.put $ M.insert (Just comment_id) new_comment_id rethread_map
forM_ (zip comment_ids new_comment_ids) $ \ (comment_id, new_comment_id) -> do
update $ \ comment_tag -> do
where_ $ comment_tag ^. CommentTagComment ==. val comment_id
set comment_tag [ CommentTagComment =. val new_comment_id ]
return new_comment_id
update $ \ ticket -> do
where_ $ ticket ^. TicketComment ==. val comment_id
set ticket [ TicketComment =. val new_comment_id ]
return (old_comment_ids, new_comment_ids)
insert_ $ CommentRethread rethread_id comment_id new_comment_id
insertSelect $
from $ \(comment_closure `InnerJoin` comment_rethread) -> do
on_ $ comment_closure ^. CommentClosureComment ==. comment_rethread ^. CommentRethreadOldComment
return $ CommentClosure
<# (comment_closure ^. CommentClosureTs)
<&> (comment_closure ^. CommentClosureClosedBy)
<&> (comment_closure ^. CommentClosureType)
<&> (comment_closure ^. CommentClosureReason)
<&> (comment_rethread ^. CommentRethreadNewComment)
now <- liftIO getCurrentTime
let new_root_comment_id = Prelude.head new_comment_ids -- This is kind of ugly, but it should be safe.
rethread = Rethread now user_id root_comment_id new_root_comment_id reason
rethread_id <- lift (insert rethread)
tell [ECommentRethreaded rethread_id rethread]
lift $ do
forM_ (zip old_comment_ids new_comment_ids) $ \ (comment_id, new_comment_id) -> do
update $ \ comment_tag -> do
where_ $ comment_tag ^. CommentTagComment ==. val comment_id
set comment_tag [ CommentTagComment =. val new_comment_id ]
update $ \ ticket -> do
where_ $ ticket ^. TicketComment ==. val comment_id
set ticket [ TicketComment =. val new_comment_id ]
insert_ $ CommentRethread rethread_id comment_id new_comment_id
insertSelect $
from $ \(c `InnerJoin` ca) -> do
on_ (c ^. CommentParent ==. just (ca ^. CommentAncestorComment))
where_ (c ^. CommentId ==. val new_comment_id)
return (CommentAncestor <# val new_comment_id <&> (ca ^. CommentAncestorAncestor))
[Value maybe_new_parent_id] <-
select $
from $ \c -> do
where_ (c ^. CommentId ==. val new_comment_id)
return (c ^. CommentParent)
maybe (return ()) (insert_ . CommentAncestor new_comment_id) maybe_new_parent_id
insertSelect $
from $ \(comment_closure `InnerJoin` comment_rethread) -> do
on_ $ comment_closure ^. CommentClosureComment ==. comment_rethread ^. CommentRethreadOldComment
return $ CommentClosure
<# (comment_closure ^. CommentClosureTs)
<&> (comment_closure ^. CommentClosureClosedBy)
<&> (comment_closure ^. CommentClosureType)
<&> (comment_closure ^. CommentClosureReason)
<&> (comment_rethread ^. CommentRethreadNewComment)
delete $
from $ \ca ->
where_ $ ca ^. CommentAncestorComment `in_` valList old_comment_ids
makeCommentRouteDB :: CommentId -> DB (Maybe (Route App))
makeCommentRouteDB comment_id = get comment_id >>= \case
Nothing -> return Nothing
Just comment -> fetchDiscussionDB (commentDiscussion comment) >>= \case
DiscussionOnProject (Entity _ project) -> return (Just (ProjectCommentR (projectHandle project) comment_id))
DiscussionOnWikiPage (Entity _ wiki_page) -> do
project <- getJust (wikiPageProject wiki_page)
return (Just (WikiCommentR (projectHandle project) (wikiPageTarget wiki_page) comment_id))
return new_comment_ids
......@@ -77,22 +77,28 @@ exprCommentRootPostedBy user_id c = ((isNothing (c ^. CommentParent)) &&. c ^. C
-- If logged in, show all approved (hiding flagged), plus own comments (unapproved + flagged).
-- If not logged in, show all approved (hiding flagged).
-- No matter what, hide rethreaded comments (they've essentially been replaced).
-- TODO(mitchell, david): rethink this function with regards to comment visibility
exprCommentProjectPermissionFilter :: Maybe UserId -> SqlExpr (Value ProjectId) -> ExprCommentCond
exprCommentProjectPermissionFilter muser_id project_id c = exprCommentNotRethreaded c &&. permissionFilter &&. isVisible
exprCommentProjectPermissionFilter muser_id project_id c =
exprCommentNotRethreaded c &&. exprCommentProjectPermissionFilterIncludingRethreaded muser_id project_id c
-- | A "special case" of the above (almost universal) permission filter, for Project feeds: we *do*
-- want to display rethreaded Comments in this case, because otherwise, the original "comment posted"
-- feed events would vanish.
exprCommentProjectPermissionFilterIncludingRethreaded :: Maybe UserId -> SqlExpr (Value ProjectId) -> ExprCommentCond
exprCommentProjectPermissionFilterIncludingRethreaded muser_id project_id c = isVisible &&. permissionFilter
where
permissionFilter :: SqlExpr (Value Bool)
permissionFilter = case muser_id of
Just user_id -> approvedAndNotFlagged ||. exprCommentPostedBy user_id c ||. exprUserIsModerator user_id project_id
Nothing -> approvedAndNotFlagged
-- isVisible when comment is public (VisPublic), or the viewer is
-- a project team member, or the viewer posted the topic initially
isVisible :: SqlExpr (Value Bool)
isVisible = seq (appendFile "testlog" $ "isVisible for " ++ show muser_id) $ case muser_id of
-- TODO(mitchell, david): this is wrong, but good enough for now
isVisible = case muser_id of
Just user_id -> c ^. CommentVisibility ==. val VisPublic ||. exprUserIsTeamMember user_id project_id ||. exprCommentRootPostedBy user_id c
Nothing -> c ^. CommentVisibility ==. val VisPublic
approvedAndNotFlagged :: SqlExpr (Value Bool)
permissionFilter = case muser_id of
Just user_id -> approvedAndNotFlagged ||. exprCommentPostedBy user_id c ||. exprUserIsModerator user_id project_id
Nothing -> approvedAndNotFlagged
approvedAndNotFlagged = exprCommentApproved c &&. not_ (exprCommentFlagged c)
querCommentAncestors :: CommentId -> SqlQuery (SqlExpr (Value CommentId))
......
module Model.Discussion
( createDiscussionDB
( DiscussionOn(..)
, createDiscussionDB
, fetchDiscussionClosedRootCommentsDB
, fetchDiscussionProjectDB
, fetchDiscussionDB
, fetchDiscussionsDB
, fetchDiscussionRootCommentsDB
, fetchDiscussionWikiPage
, fetchDiscussionWikiPagesInDB
) where
import Import
......@@ -12,6 +12,82 @@ import Import
import Model.Comment.Sql
import Control.Monad.Trans.Maybe
import qualified Data.Map as M
-- | An internal sum type that contains a constructer per database table that acts
-- as a "Discussion". This way, we get a relatively type-safe way of ensuring that
-- all possible such tables are referenced when fetching the data associated with
-- some arbitrary Discussion.
--
-- Any new Discussion-ey tables MUST have a constructor added here! (and below, too)
data DiscussionType
= DiscussionTypeProject
| DiscussionTypeWikiPage
deriving (Bounded, Enum)
-- | Similar to DiscussionType, but exported, and actually contains the data.
data DiscussionOn
= DiscussionOnProject (Entity Project)
| DiscussionOnWikiPage (Entity WikiPage)
-- | Given a 'requested' DiscussionType, attempt to fetch the Discussion from that
-- table. If, say, the requested DiscussionType is DiscussionTypeProject, but the
-- given DiscussionId corresponds to a discussion on a WikiPage, this function
-- will return Nothing.
--
-- TODO(mitchell): Make this function more type safe.
fetchDiscussionInternal :: DiscussionId -> DiscussionType -> DB (Maybe DiscussionOn)
fetchDiscussionInternal discussion_id DiscussionTypeProject = fmap (fmap DiscussionOnProject . listToMaybe) $
select $
from $ \p -> do
where_ (p ^. ProjectDiscussion ==. val discussion_id)
return p
fetchDiscussionInternal discussion_id DiscussionTypeWikiPage = fmap (fmap DiscussionOnWikiPage . listToMaybe) $
select $
from $ \wp -> do
where_ (wp ^. WikiPageDiscussion ==. val discussion_id)
return wp
fetchDiscussionsInternal :: [DiscussionId] -> DiscussionType -> DB (Map DiscussionId DiscussionOn)
fetchDiscussionsInternal discussion_ids DiscussionTypeProject = fmap (foldr go mempty) $
select $
from $ \p -> do
where_ (p ^. ProjectDiscussion `in_` valList discussion_ids)
return p
where
go :: Entity Project -> Map DiscussionId DiscussionOn -> Map DiscussionId DiscussionOn
go p@(Entity _ Project{..}) = M.insert projectDiscussion (DiscussionOnProject p)
fetchDiscussionsInternal discussion_ids DiscussionTypeWikiPage = fmap (foldr go mempty) $
select $
from $ \wp -> do
where_ (wp ^. WikiPageDiscussion `in_` valList discussion_ids)
return wp
where
go :: Entity WikiPage -> Map DiscussionId DiscussionOn -> Map DiscussionId DiscussionOn
go w@(Entity _ WikiPage{..}) = M.insert wikiPageDiscussion (DiscussionOnWikiPage w)