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

Commit 5d1234b3 authored by Mitchell Rosen's avatar Mitchell Rosen

rip out FeedEvent

parent 58bc2474
......@@ -5,17 +5,21 @@ module Handler.Project where
import Import
import Model.Currency
import Model.Discussion
import Model.Project
import Model.Shares
import Model.Markdown
import Model.Markdown.Diff
import Model.SnowdriftEvent
import Model.User
import Model.WikiPage
import View.PledgeButton
import View.SnowdriftEvent
import Widgets.Markdown
import Widgets.Preview
import Widgets.Time
import Data.List (sort)
import Data.List (sortBy)
import qualified Data.Map as M
import Data.Maybe (fromJust, maybeToList)
import qualified Data.Text as T
......@@ -417,38 +421,33 @@ postUnwatchProjectR = undefined -- TODO(mitchell)
--------------------------------------------------------------------------------
-- /feed
-- Analogous data types to SnowdriftEvent, but specialized for displaying the feed.
-- This is necessary because there is some extra information required for displaying
-- feed items not present in SnowdriftEvents, such as the WikiPage that a Comment
-- was made on.
data FeedEvent = FeedEvent UTCTime FeedEventData
deriving Eq
data FeedEventData
= FECommentPostedOnWikiPage (Entity Comment) (Entity WikiPage)
| FEWikiEdit (Entity WikiEdit) (Entity WikiPage)
deriving Eq
-- | Order FeedEvents by reverse timestamp (newer comes first).
instance Ord FeedEvent where
compare (FeedEvent time1 _) (FeedEvent time2 _) = compare time2 time1
-- | If an unapproved comment is passed to this function, bad things will happen.
mkCommentPostedOnWikiPageFeedEvent :: Entity Comment -> Entity WikiPage -> FeedEvent
mkCommentPostedOnWikiPageFeedEvent c@(Entity _ Comment{..}) wp =
FeedEvent (fromJust commentModeratedTs) (FECommentPostedOnWikiPage c wp)
mkWikiEditFeedEvent :: Entity WikiEdit -> Entity WikiPage -> FeedEvent
mkWikiEditFeedEvent we@(Entity _ WikiEdit{..}) wp = FeedEvent wikiEditTs (FEWikiEdit we wp)
-- | This function is responsible for hitting every relevant event table. Nothing
-- statically guarantees that.
getProjectFeedR :: Text -> Handler Html
getProjectFeedR project_handle = do
before <- maybe (liftIO getCurrentTime) (return . read . T.unpack) =<< lookupGetParam "before"
events <- runYDB $ do
(events, discussion_wiki_pages_map, wiki_pages_map, users_map) <- runYDB $ do
Entity project_id _ <- getBy404 (UniqueProjectHandle project_handle)
comments_posted <- map (uncurry mkCommentPostedOnWikiPageFeedEvent) <$> fetchProjectCommentsPostedOnWikiPagesDB project_id before
wiki_edits <- map (uncurry mkWikiEditFeedEvent) <$> fetchProjectWikiEditsDB project_id before
return (sort $ comments_posted ++ wiki_edits)
comment_entities <- fetchProjectCommentsPostedOnWikiPagesDB project_id before
wiki_edit_entities <- fetchProjectWikiEditsDB project_id before
-- Suplementary maps for displaying the data.
let comments = map entityVal comment_entities
wiki_edits = map entityVal wiki_edit_entities
discussion_wiki_pages_map <- M.fromList . map (\e@(Entity _ WikiPage{..}) -> (wikiPageDiscussion, e)) <$>
fetchDiscussionWikiPagesInDB (map commentDiscussion comments)
wiki_pages_map <- entitiesMap <$> fetchWikiPagesInDB (map wikiEditPage wiki_edits)
users_map <- (<>)
<$> (entitiesMap <$> fetchUsersInDB (map commentUser comments))
<*> (entitiesMap <$> fetchUsersInDB (map wikiEditUser wiki_edits))
let events = sortBy snowdriftEventNewestToOldest . mconcat $
[ map (onEntity ECommentPosted) comment_entities
, map (onEntity EWikiEdit) wiki_edit_entities
]
return (events, discussion_wiki_pages_map, wiki_pages_map, users_map)
defaultLayout $(widgetFile "project_feed")
......@@ -198,7 +198,7 @@ getDiscussWikiR' project_handle target get_root_comments = do
(roots, replies, user_map, closure_map, ticket_map, flag_map, tag_map) <- runDB $ do
roots <- get_root_comments muser_id project_id (wikiPageDiscussion page)
replies <- getCommentsDescendants muser_id project_id (map entityKey roots)
user_map <- entitiesMap <$> getUsersIn (S.toList $ getCommentsUsers roots <> getCommentsUsers replies)
user_map <- entitiesMap <$> fetchUsersInDB (S.toList $ getCommentsUsers roots <> getCommentsUsers replies)
let comment_ids = map entityKey (roots ++ replies)
closure_map <- makeClosureMap comment_ids
ticket_map <- makeTicketMap comment_ids
......
......@@ -896,7 +896,7 @@ makeCommentWidgetMod CommentMods{..} get_max_depth show_actions form_under_root_
all_comment_ids = map entityKey all_comments
earlier_closures <- getAncestorClosures comment_id
user_map <- entitiesMap <$> getUsersIn (S.toList $ getCommentsUsers all_comments)
user_map <- entitiesMap <$> fetchUsersInDB (S.toList $ getCommentsUsers all_comments)
closure_map <- makeClosureMap all_comment_ids
ticket_map <- makeTicketMap all_comment_ids
flag_map <- makeFlagMap all_comment_ids
......
......@@ -8,6 +8,7 @@ import Model as Import
import Model.Comment.Internal as Import
import Model.Established.Internal as Import
import Model.Role.Internal as Import
import Model.SnowdriftEvent.Internal as Import
import Settings as Import
import Settings.Development as Import
import Settings.StaticFiles as Import
......@@ -254,6 +255,10 @@ instance (WrappedValues a, WrappedValues b, WrappedValues c) => WrappedValues (a
type Unwrapped (a, b, c) = (Unwrapped a, Unwrapped b, Unwrapped c)
unwrapValues (a, b, c) = (unwrapValues a, unwrapValues b, unwrapValues c)
-- | Convenience function for unwrapping an Entity and supplying both the key and value to another function.
onEntity :: (Key a -> a -> b) -> Entity a -> b
onEntity f (Entity x y) = f x y
{- The following footnote and toc functions were used our pre-wiki about page
At the time of this comment, they are no longer used anywhere live. -}
......
......@@ -51,7 +51,6 @@ import Import
import Model.Comment.Sql
import Model.Message
import Model.SnowdriftEvent.Internal
import qualified Control.Monad.State as St
import Control.Monad.Writer.Strict (tell)
......
module Model.Discussion
( fetchDiscussionWikiPagesInDB
) where
import Import
-- | Given a list of DiscussionId, fetch the discussions which are WikiPages.
fetchDiscussionWikiPagesInDB :: [DiscussionId] -> DB [Entity WikiPage]
fetchDiscussionWikiPagesInDB discussion_ids =
select $
from $ \wp -> do
where_ (wp ^. WikiPageDiscussion `in_` valList discussion_ids)
return wp
......@@ -6,7 +6,6 @@ module Model.Message
import Import
import Model.Message.Internal
import Model.SnowdriftEvent.Internal
import Control.Monad.Writer.Strict (tell)
......
......@@ -13,7 +13,7 @@ data MessageType
-- Project scope
| MessageNewPledger
| MessageNewPage
deriving (Read, Show)
deriving (Eq, Read, Show)
derivePersistField "MessageType"
showMessageType :: MessageType -> Text
......
......@@ -149,7 +149,7 @@ getProjectWikiPages project_id =
return wp
-- | Fetch all Comments posted on some Project's WikiPages.
fetchProjectCommentsPostedOnWikiPagesDB :: ProjectId -> UTCTime -> DB [(Entity Comment, Entity WikiPage)]
fetchProjectCommentsPostedOnWikiPagesDB :: ProjectId -> UTCTime -> DB [Entity Comment]
fetchProjectCommentsPostedOnWikiPagesDB project_id before =
select $
from $ \(ecp `InnerJoin` c `InnerJoin` wp) -> do
......@@ -158,10 +158,10 @@ fetchProjectCommentsPostedOnWikiPagesDB project_id before =
where_ $
ecp ^. EventCommentPostedTs <=. val before &&.
wp ^. WikiPageProject ==. val project_id
return (c, wp)
return c
-- | Fetch all WikiEdits made on some Project.
fetchProjectWikiEditsDB :: ProjectId -> UTCTime -> DB [(Entity WikiEdit, Entity WikiPage)]
fetchProjectWikiEditsDB :: ProjectId -> UTCTime -> DB [Entity WikiEdit]
fetchProjectWikiEditsDB project_id before =
select $
from $ \(ewe `InnerJoin` we `InnerJoin` wp) -> do
......@@ -170,4 +170,4 @@ fetchProjectWikiEditsDB project_id before =
where_ $
ewe ^. EventWikiEditTs <=. val before &&.
wp ^. WikiPageProject ==. val project_id
return (we, wp)
return we
module Model.SnowdriftEvent
( snowdriftEventNewestToOldest
) where
import Import
snowdriftEventNewestToOldest :: SnowdriftEvent -> SnowdriftEvent -> Ordering
snowdriftEventNewestToOldest x y = compare (snowdriftEventTime y) (snowdriftEventTime x)
snowdriftEventTime :: SnowdriftEvent -> UTCTime
snowdriftEventTime (ECommentPosted _ Comment{..}) = fromMaybe commentCreatedTs commentModeratedTs
snowdriftEventTime (ECommentPending _ Comment{..}) = commentCreatedTs
snowdriftEventTime (EMessageSent _ Message{..}) = messageCreatedTs
snowdriftEventTime (EWikiEdit _ WikiEdit{..}) = wikiEditTs
module Model.SnowdriftEvent.Internal where
module Model.SnowdriftEvent.Internal
( SnowdriftEvent(..)
) where
import Model
......
......@@ -7,12 +7,12 @@ module Model.User
, eligEstablishUser
, establishUser
, fetchUserMessagePrefDB
, fetchUsersInDB
-- TODO(mitchell): consistent naming scheme
, getAllRoles
, getCurUserRoles
, getProjectsAndRoles
, getRoles
, getUsersIn
, hasRole
, isCurUserEligibleEstablish
, isCurUserProjectModerator
......@@ -52,8 +52,8 @@ data UserUpdate =
-- , userUpdateMessagePreferences :: Maybe [MessagePreference]
}
getUsersIn :: [UserId] -> DB [Entity User]
getUsersIn user_ids = selectList [UserId <-. user_ids] []
fetchUsersInDB :: [UserId] -> DB [Entity User]
fetchUsersInDB user_ids = selectList [UserId <-. user_ids] []
updateUser :: UserId -> UserUpdate -> DB ()
updateUser user_id UserUpdate{..} =
......
module Model.WikiPage
( getAllWikiComments
, fetchWikiPagesInDB
) where
import Import
......@@ -7,6 +8,13 @@ import Import
import Model.Comment.Sql
import Model.Project (getProjectPages)
fetchWikiPagesInDB :: [WikiPageId] -> DB [Entity WikiPage]
fetchWikiPagesInDB wiki_page_ids =
select $
from $ \wp -> do
where_ (wp ^. WikiPageId `in_` valList wiki_page_ids)
return wp
-- | Get the unapproved, new and old Comments on all WikiPages of Project. Takes a
-- UTCTime 'since' to filter comments EARLIER than this time, and a CommentId
-- 'latest_comment_id' to filter comments AFTER this comment (used for paging).
......
......@@ -33,6 +33,7 @@ library
Model.Comment
Model.Comment.Sql
Model.Currency
Model.Discussion
Model.Issue
Model.Markdown
Model.Markdown.Diff
......@@ -42,6 +43,7 @@ library
Model.Role
Model.Settings
Model.Shares
Model.SnowdriftEvent
Model.SnowdriftEvent.Internal
Model.Tag
Model.Ticket
......@@ -81,6 +83,7 @@ library
Handler.Wiki
Handler.Wiki.Comment
View.Comment
View.SnowdriftEvent
View.User
View.Wiki
View.PledgeButton
......
-- | Put all CSS for these widgets in templates/project_feed.cassius
module View.SnowdriftEvent where
import Import
renderCommentPostedOnWikiPageEvent :: CommentId -> Comment -> Entity WikiPage -> Widget
renderCommentPostedOnWikiPageEvent comment_id comment (Entity wiki_page_id wiki_page) =
[whamlet|
<div>On #{wikiPageTarget wiki_page}: #{commentText comment}
\ <a href=@{CommentDirectLinkR comment_id}>(permalink)
|]
-- This should really *never* be called, but it's included in case of nuclear meltdown.
renderCommentPostedOnUnknownDiscussionEvent :: CommentId -> Comment -> Widget
renderCommentPostedOnUnknownDiscussionEvent comment_id comment =
[whamlet|
<div>#{commentText comment}
\ <a href=@{CommentDirectLinkR comment_id}>(permalink)
|]
renderWikiEditEvent :: WikiEditId -> WikiEdit -> Entity WikiPage -> Widget
renderWikiEditEvent wiki_edit_id wiki_edit (Entity wiki_page_id wiki_page) =
[whamlet|
<div>#{wikiPageTarget wiki_page} edit!
|]
......@@ -169,6 +169,7 @@ Message
content Markdown
-- Whether the message was sent automatically by Snowdrift, or by an actual user.
automated Bool default=false
deriving Eq
WikiPage
target Text
......
......@@ -2,8 +2,24 @@
$forall event <- events
$case event
$of FeedEvent _ (FECommentPostedOnWikiPage (Entity comment_id comment) (Entity _ wiki_page))
<div>On #{wikiPageTarget wiki_page}: #{commentText comment}
\ <a href=@{CommentDirectLinkR comment_id}>(permalink)
$of FeedEvent _ (FEWikiEdit (Entity _ _) (Entity _ wiki_page))
<div>#{wikiPageTarget wiki_page} edit!
$of ECommentPosted comment_id comment
$# Here we must discover what kind of discussion the comment was posted
$# on by looking in each map in order. There ought to be a nicer
$# way to do this, but I'd like to keep both of:
$# - ECommentPosted not being split into a different event for
$# each location a comment might be posted.
$# - A single event data type (as opposed to something like
$# FeedEvent that specialized SnowdriftEvent, e.g.
$# FECommentPostedOnWikiPage)
$maybe wiki_page <- M.lookup (commentDiscussion comment) discussion_wiki_pages_map
^{renderCommentPostedOnWikiPageEvent comment_id comment wiki_page}
$# This should never happen.
$nothing
^{renderCommentPostedOnUnknownDiscussionEvent comment_id comment}
$of EWikiEdit wiki_edit_id wiki_edit
^{renderWikiEditEvent wiki_edit_id wiki_edit (Entity (wikiEditPage wiki_edit) (fromJust $ M.lookup (wikiEditPage wiki_edit) wiki_pages_map))}
......@@ -15,4 +15,3 @@
<hr .wikitop>
^{markdownWidget project_handle (wikiEditContent edit)}
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