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

Commit a19c7e7f authored by David L. L. Thomas's avatar David L. L. Thomas

Blog posting events

parent 9daedd69
......@@ -10,6 +10,7 @@ import Handler.Comment
import Handler.Discussion
import Handler.Utils
import Model.Application
import Model.Blog
import Model.Comment
import Model.Comment.ActionPermissions
import Model.Comment.HandlerInfo
......@@ -33,6 +34,8 @@ import View.SnowdriftEvent
import Widgets.Preview
import Widgets.Time
import Yesod.Markdown
import Data.Default (def)
import qualified Data.Foldable as F
import Data.List (sortBy)
......@@ -336,13 +339,13 @@ getProjectBlogR project_handle = do
post_count <- fromMaybe 10 <$> fmap (read . T.unpack) <$> lookupGetParam "from"
Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle
let apply_offset blog = maybe id (\ from_blog rest -> blog ^. ProjectBlogId >=. val from_blog &&. rest) maybe_from
let apply_offset blog = maybe id (\ from_blog rest -> blog ^. BlogPostId >=. val from_blog &&. rest) maybe_from
(posts, next) <- fmap (splitAt post_count) $ runDB $
select $
from $ \blog -> do
where_ $ apply_offset blog $ blog ^. ProjectBlogProject ==. val project_id
orderBy [ desc $ blog ^. ProjectBlogTime, desc $ blog ^. ProjectBlogId ]
where_ $ apply_offset blog $ blog ^. BlogPostProject ==. val project_id
orderBy [ desc $ blog ^. BlogPostTs, desc $ blog ^. BlogPostId ]
limit (fromIntegral post_count + 1)
return blog
......@@ -378,30 +381,21 @@ postNewProjectBlogPostR project_handle = do
((result, _), _) <- runFormPost $ projectBlogForm Nothing
case result of
FormSuccess mk_blog_post -> do
FormSuccess (title, handle, Markdown content) -> do
lookupPostMode >>= \case
Just PostMode -> do
void $ runDB $ do
discussion_id <- insert $ Discussion 0
let blog_post :: ProjectBlog
blog_post = mk_blog_post now viewer_id project_id discussion_id
insert blog_post
void $ runSDB $ postBlogPostDB title handle viewer_id project_id (Markdown content)
alertSuccess "posted"
redirect $ ProjectBlogR project_handle
_ -> do
let blog_post :: ProjectBlog
blog_post = mk_blog_post now viewer_id project_id (Key $ PersistInt64 0)
title = projectBlogTitle blog_post
handle = projectBlogHandle blog_post
top_content = projectBlogTopContent blog_post
bottom_content = fromMaybe "" $ projectBlogBottomContent blog_post
content = top_content <> bottom_content
(form, _) <- generateFormPost $ projectBlogForm $ Just (title, handle, content)
let (top_content', bottom_content') = break (== "***") $ T.lines content
top_content = T.unlines top_content'
bottom_content = if bottom_content' == [] then Nothing else Just (Markdown $ T.unlines bottom_content')
blog_post = BlogPost now title handle viewer_id project_id (Key $ PersistInt64 0) (Markdown top_content) bottom_content
(form, _) <- generateFormPost $ projectBlogForm $ Just (title, handle, Markdown content)
defaultLayout $ previewWidget form "post" $ renderBlogPost project_handle blog_post
......@@ -414,12 +408,12 @@ getProjectBlogPostR :: Text -> Text -> Handler Html
getProjectBlogPostR project_handle blog_post_handle = do
(project, blog_post) <- runYDB $ do
Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle
Entity _ blog_post <- getBy404 $ UniqueProjectBlogPost project_id blog_post_handle
Entity _ blog_post <- getBy404 $ UniqueBlogPost project_id blog_post_handle
return (project, blog_post)
defaultLayout $ do
setTitle . toHtml $ projectName project <> " Blog - " <> projectBlogTitle blog_post <> " | Snowdrift.coop"
setTitle . toHtml $ projectName project <> " Blog - " <> blogPostTitle blog_post <> " | Snowdrift.coop"
renderBlogPost project_handle blog_post
......@@ -870,7 +864,7 @@ getProjectFeedR project_handle = do
before <- lookupGetUTCTimeDefaultNow "before"
(project, comments, rethreads, wiki_pages, wiki_edits, new_pledges,
(project, comments, rethreads, wiki_pages, wiki_edits, blog_posts, 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, claim_map, flag_map) <- runYDB $ do
......@@ -880,6 +874,7 @@ getProjectFeedR project_handle = do
comments <- fetchProjectCommentsIncludingRethreadedBeforeDB project_id muser_id before lim
rethreads <- fetchProjectCommentRethreadsBeforeDB project_id muser_id before lim
wiki_pages <- fetchProjectWikiPagesBeforeDB project_id before lim
blog_posts <- fetchProjectBlogPostsBeforeDB 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
......@@ -890,14 +885,17 @@ getProjectFeedR project_handle = do
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
(blog_post_users) = F.foldMap (\(Entity _ e) -> ([blogPostUser e])) blog_posts
shares_pledged = map entityVal (new_pledges <> (map snd updated_pledges))
-- All users: comment posters, wiki page creators, etc.
user_ids = S.toList $
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)
user_ids = S.toList $ mconcat
[ S.fromList comment_users
, S.fromList (map (rethreadModerator . entityVal) rethreads)
, S.fromList wiki_edit_users
, S.fromList blog_post_users
, S.fromList (map sharesPledgedUser shares_pledged)
, S.fromList (map eventDeletedPledgeUser deleted_pledges)
]
discussion_map <- fetchProjectDiscussionsDB project_id >>= fetchDiscussionsDB
......@@ -914,7 +912,7 @@ getProjectFeedR project_handle = do
claim_map <- makeClaimedTicketMapDB comment_ids
flag_map <- makeFlagMapDB comment_ids
return (project, comments, rethreads, wiki_pages, wiki_edits,
return (project, comments, rethreads, wiki_pages, wiki_edits, blog_posts,
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,
......@@ -927,6 +925,7 @@ getProjectFeedR project_handle = do
, map (onEntity ECommentRethreaded) rethreads
, map (onEntity EWikiPage) wiki_pages
, map (onEntity EWikiEdit) wiki_edits
, map (onEntity EBlogPost) blog_posts
, map (onEntity ENewPledge) new_pledges
, map eup2se updated_pledges
, map edp2se deleted_pledges
......
module Model.Blog (postBlogPostDB) where
import Import
import Control.Monad.Writer.Strict (tell)
import Yesod.Markdown
import qualified Data.Text as T
postBlogPostDB :: Text -> Text -> UserId -> ProjectId -> Markdown -> SDB BlogPostId
postBlogPostDB title handle user_id project_id content = do
let (top_content, bottom_content) = transform content
now <- liftIO getCurrentTime
(post_id, post) <- lift $ do
discussion_id <- insert $ Discussion 0
let doInsert counter = do
let modifier = maybe "" (T.cons '~' . T.pack . show) (counter :: Maybe Integer)
next_counter = Just $ maybe 2 (+1) counter
post = BlogPost now title (handle <> modifier) user_id project_id discussion_id top_content bottom_content
maybe_post_id <- insertUnique post
case maybe_post_id of
Just post_id -> return (post_id, post)
_ -> doInsert next_counter
doInsert Nothing
tell [EBlogPost post_id post]
return post_id
where
transform (Markdown text) = case break (== "***") (T.lines text) of
-- TODO: reject empty content above the fold?
(top, []) -> (Markdown $ T.unlines top, Nothing)
(top, ["***"]) -> (Markdown $ T.unlines top, Nothing)
(top, "***":bottom) -> (Markdown $ T.unlines top, Just $ Markdown $ T.unlines bottom)
(_, _) -> error "cannot result from a break"
......@@ -14,6 +14,7 @@ module Model.Project
, fetchProjectVolunteerApplicationsDB
, fetchProjectWikiEditsBeforeDB
, fetchProjectWikiPagesBeforeDB
, fetchProjectBlogPostsBeforeDB
, fetchProjectWikiPageByNameDB
, insertProjectPledgeDB
-- TODO(mitchell): rename all these... prefix fetch, suffix DB
......@@ -302,6 +303,19 @@ fetchProjectWikiPagesBeforeDB project_id before lim =
limit lim
return wp
-- | Fetch all BlogPosts made on this Project before this time.
fetchProjectBlogPostsBeforeDB :: ProjectId -> UTCTime -> Int64 -> DB [Entity BlogPost]
fetchProjectBlogPostsBeforeDB project_id before lim =
select $
from $ \(ebp `InnerJoin` bp) -> do
on_ (ebp ^. EventBlogPostPost ==. bp ^. BlogPostId)
where_ $
ebp ^. EventBlogPostTs <=. val before &&.
bp ^. BlogPostProject ==. val project_id
orderBy [ desc $ ebp ^. EventBlogPostTs, desc $ ebp ^. EventBlogPostId ]
limit lim
return bp
-- | Fetch all WikiEdits made on this Project before this time.
fetchProjectWikiEditsBeforeDB :: ProjectId -> UTCTime -> Int64 -> DB [Entity WikiEdit]
fetchProjectWikiEditsBeforeDB project_id before lim =
......
......@@ -23,6 +23,7 @@ snowdriftEventTime (ECommentRethreaded _ Rethread{..}) = rethreadTs
snowdriftEventTime (ENotificationSent _ Notification{..}) = notificationCreatedTs
snowdriftEventTime (EWikiEdit _ WikiEdit{..}) = wikiEditTs
snowdriftEventTime (EWikiPage _ WikiPage{..}) = wikiPageCreatedTs
snowdriftEventTime (EBlogPost _ BlogPost{..}) = blogPostTs
snowdriftEventTime (ENewPledge _ SharesPledged{..}) = sharesPledgedTs
snowdriftEventTime (EUpdatedPledge _ _ SharesPledged{..}) = sharesPledgedTs
snowdriftEventTime (EDeletedPledge ts _ _ _) = ts
......@@ -82,6 +83,22 @@ snowdriftEventToFeedEntry render project_handle user_map _ wiki_page_map (EWikiE
, feedEntryContent = [hamlet| |] render
}
snowdriftEventToFeedEntry render project_handle _ _ _
( EBlogPost _
BlogPost
{ blogPostHandle = handle
, blogPostTs = ts
, blogPostTitle = title
}
) =
Just $ FeedEntry
{ feedEntryLink = ProjectBlogR handle
, feedEntryUpdated = ts
, feedEntryTitle = T.unwords [ T.snoc project_handle ':', "new blog post:", "\"" <> title <> "\"" ]
, feedEntryContent = [hamlet| |] render
}
-- We might want to show these, but I'm not sure. Leaving them out now, at any rate.
snowdriftEventToFeedEntry _ _ _ _ _ (ENewPledge _ _) = Nothing
snowdriftEventToFeedEntry _ _ _ _ _ (EUpdatedPledge _ _ _) = Nothing
......
......@@ -20,6 +20,8 @@ data SnowdriftEvent
| EWikiEdit WikiEditId WikiEdit
-- New WikiPage posted.
| EWikiPage WikiPageId WikiPage
-- New blog post posted.
| EBlogPost BlogPostId BlogPost
-- New pledge.
| ENewPledge SharesPledgedId SharesPledged
-- Pledge that has changed in value.
......
......@@ -29,6 +29,7 @@ library
Import
Model
Model.Application
Model.Blog
Model.CollapseState
Model.Comment
Model.Comment.ActionPermissions
......
......@@ -96,6 +96,7 @@ notificationEventHandler (ECommentRethreaded _ Rethread{..}) = do
notificationEventHandler (ENotificationSent _ _) = return ()
notificationEventHandler (EWikiEdit _ _) = return ()
notificationEventHandler (EWikiPage _ _) = return ()
notificationEventHandler (EBlogPost _ _) = return ()
notificationEventHandler (ENewPledge _ _) = return ()
notificationEventHandler (EUpdatedPledge _ _ _) = return ()
notificationEventHandler (EDeletedPledge _ _ _ _) = return ()
......@@ -112,3 +113,4 @@ eventInserterHandler (EWikiEdit wiki_edit_id WikiEdit{..})
eventInserterHandler (ENewPledge shares_pledged_id SharesPledged{..}) = runDB (insert_ (EventNewPledge sharesPledgedTs shares_pledged_id))
eventInserterHandler (EUpdatedPledge old_shares shares_pledged_id SharesPledged{..}) = runDB (insert_ (EventUpdatedPledge sharesPledgedTs old_shares shares_pledged_id))
eventInserterHandler (EDeletedPledge ts user_id project_id shares) = runDB (insert_ (EventDeletedPledge ts user_id project_id shares))
eventInserterHandler (EBlogPost post_id BlogPost{..}) = runDB (insert_ (EventBlogPost blogPostTs post_id))
......@@ -71,11 +71,11 @@ renderProject maybe_project_id project pledges pledge = do
$(widgetFile "project")
renderBlogPost :: Text -> ProjectBlog -> WidgetT App IO ()
renderBlogPost :: Text -> BlogPost -> WidgetT App IO ()
renderBlogPost project_handle blog_post = do
let (Markdown top_content) = projectBlogTopContent blog_post
(Markdown bottom_content) = maybe (Markdown "") ("***\n" <>) $ projectBlogBottomContent blog_post
title = projectBlogTitle blog_post
let (Markdown top_content) = blogPostTopContent blog_post
(Markdown bottom_content) = maybe (Markdown "") ("***\n" <>) $ blogPostBottomContent blog_post
title = blogPostTitle blog_post
content = markdownWidgetWith (fixLinks project_handle) $ Markdown $ T.snoc top_content '\n' <> bottom_content
$(widgetFile "blog_post")
......@@ -88,22 +88,15 @@ editProjectForm project =
<*> (maybe [] (map T.strip . T.splitOn ",") <$> aopt' textField "Tags" (Just . T.intercalate ", " . snd <$> project))
<*> aopt' textField "Github Repository" (projectGithubRepo . fst <$> project)
projectBlogForm :: Maybe (Text, Text, Markdown) -> Form (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
projectBlogForm :: Maybe (Text, Text, Markdown) -> Form (Text, Text, Markdown)
projectBlogForm defaults = renderBootstrap3 $
let getTitle (title, _, _) = title
getHandle (_, handle, _) = handle
getContent (_, _, content) = content
in mkBlog
in (,,)
<$> areq' textField "Post Title" (getTitle <$> defaults)
<*> areq' textField "Post Handle" (getHandle <$> defaults)
<*> areq' snowdriftMarkdownField "Content" (getContent <$> defaults)
where
mkBlog :: Text -> Text -> Markdown -> (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
mkBlog title handle (Markdown content) now user_id project_id discussion_id =
let (top_content, bottom_content) = break (== "***") $ T.lines content
in ProjectBlog now title handle user_id project_id
discussion_id (Markdown $ T.unlines top_content)
(if null bottom_content then Nothing else Just $ Markdown $ T.unlines bottom_content)
projectContactForm :: Form Markdown
projectContactForm = renderBootstrap3 $ areq' snowdriftMarkdownField "" Nothing
......
......@@ -171,6 +171,16 @@ renderWikiEditEvent project_handle edit_id wiki_edit wiki_page_map user_map = do
see this edit version <!-- TODO: make this link to the diff instead -->
|]
renderBlogPostEvent :: BlogPost -> Widget
renderBlogPostEvent (BlogPost {..}) =
[whamlet|
<div .event>
^{renderTime blogPostTs}
New blog post: #
<a href=@{ProjectBlogR blogPostHandle}>
#{blogPostTitle}
|]
renderNewPledgeEvent :: SharesPledgedId -> SharesPledged -> UserMap -> Widget
renderNewPledgeEvent _ SharesPledged{..} user_map = do
let pledger = lookupErr "renderNewPledgeEvent: pledger not found in user map" sharesPledgedUser user_map
......
......@@ -102,8 +102,8 @@ Project
deriving Eq Show
ProjectBlog
time UTCTime
BlogPost
ts UTCTime
title Text
handle Text
user UserId
......@@ -112,7 +112,7 @@ ProjectBlog
topContent Markdown
bottomContent Markdown Maybe
UniqueProjectBlogPost project handle
UniqueBlogPost project handle
deriving Show
......@@ -264,7 +264,7 @@ CommentClosing
UniqueCommentClosing comment
A comment-retracted relation.
-- A comment-retracted relation.
CommentRetracting
ts UTCTime
reason Markdown
......@@ -371,7 +371,7 @@ DefaultTagColor
UniqueDefaultTag tag
RoleEvent
time UTCTime
ts UTCTime
user UserId
role Role
project ProjectId
......@@ -384,7 +384,7 @@ Doc
UniqueDocName name
DocEvent
time UTCTime
ts UTCTime
doc DocId
blessedVersion WikiEditId
......@@ -451,3 +451,8 @@ EventDeletedPledge
user UserId
project ProjectId
shares Int64
EventBlogPost
ts UTCTime
post BlogPostId
ALTER TABLE project_blog RENAME COLUMN time TO ts;
ALTER TABLE project_blog RENAME TO blog_post;
ALTER TABLE role_event RENAME COLUMN time TO ts;
ALTER TABLE doc_event RENAME COLUMN time TO ts;
ALTER TABLE "blog_post" ADD CONSTRAINT "blog_post_user_fkey" FOREIGN KEY("user") REFERENCES "user"("id");
ALTER TABLE "blog_post" ADD CONSTRAINT "blog_post_project_fkey" FOREIGN KEY("project") REFERENCES "project"("id");
ALTER TABLE "blog_post" ADD CONSTRAINT "blog_post_discussion_fkey" FOREIGN KEY("discussion") REFERENCES "discussion"("id");
ALTER TABLE "blog_post" ADD CONSTRAINT "unique_blog_post" UNIQUE("project","handle");
ALTER TABLE "blog_post" DROP CONSTRAINT "unique_project_blog_post";
CREATe TABLE "event_blog_post"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"post" INT8 NOT NULL);
ALTER TABLE "event_blog_post" ADD CONSTRAINT "event_blog_post_post_fkey" FOREIGN KEY("post") REFERENCES "blog_post"("id");
$forall Entity _ post <- posts
<div .post>
<a href=@{ProjectBlogPostR project_handle (projectBlogHandle post)}>
#{projectBlogTitle post}
<a href=@{ProjectBlogPostR project_handle (blogPostHandle post)}>
#{blogPostTitle post}
\ - #
<small>
^{renderTime $ projectBlogTime post}
^{renderTime $ blogPostTs post}
<p>
^{markdownWidgetWith (fixLinks project_handle) $ projectBlogTopContent post}
^{markdownWidgetWith (fixLinks project_handle) $ blogPostTopContent post}
<hr>
......
......@@ -23,6 +23,9 @@ $forall event <- events
$of EDeletedPledge ts user_id _ shares
^{renderDeletedPledgeEvent ts user_id shares user_map}
$of EBlogPost _ blog_post
^{renderBlogPostEvent blog_post}
$# Graveyard of event types we don't want to put on the feed.
$# Don't match-all here, we don't want to accidentally not consider something.
......
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