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

Commit 9fec3c83 authored by Mitchell Rosen's avatar Mitchell Rosen

new/updated/deleted pledge events

parent 0a751d90
......@@ -389,11 +389,14 @@ messageEventHandler _ = return ()
-- | Handler in charge of inserting events (stripped down) into a separate table for each type.
eventInserterHandler :: SnowdriftEvent -> Daemon ()
-- If an unapproved comment is sent as an ECommentPosted event, bad things will happen (fromJust).
eventInserterHandler (ECommentPosted comment_id Comment{..}) = runDB (insert_ (EventCommentPosted comment_id (fromJust commentModeratedTs)))
eventInserterHandler (ECommentPending comment_id Comment{..}) = runDB (insert_ (EventCommentPending comment_id commentCreatedTs))
eventInserterHandler (EMessageSent message_id Message{..}) = runDB (insert_ (EventMessageSent message_id messageCreatedTs))
eventInserterHandler (EWikiPage wiki_page_id WikiPage{..}) = runDB (insert_ (EventWikiPage wiki_page_id wikiPageCreatedTs))
eventInserterHandler (EWikiEdit wiki_edit_id WikiEdit{..}) = runDB (insert_ (EventWikiEdit wiki_edit_id wikiEditTs))
eventInserterHandler (ECommentPosted comment_id Comment{..}) = runDB (insert_ (EventCommentPosted (fromJust commentModeratedTs) comment_id))
eventInserterHandler (ECommentPending comment_id Comment{..}) = runDB (insert_ (EventCommentPending commentCreatedTs comment_id))
eventInserterHandler (EMessageSent message_id Message{..}) = runDB (insert_ (EventMessageSent messageCreatedTs message_id))
eventInserterHandler (EWikiPage wiki_page_id WikiPage{..}) = runDB (insert_ (EventWikiPage wikiPageCreatedTs wiki_page_id))
eventInserterHandler (EWikiEdit wiki_edit_id WikiEdit{..}) = runDB (insert_ (EventWikiEdit wikiEditTs wiki_edit_id))
eventInserterHandler (ENewPledge pledge_id Pledge{..}) = runDB (insert_ (EventNewPledge pledgeCreatedTs pledge_id))
eventInserterHandler (EUpdatedPledge old_shares pledge_id Pledge{..}) = runDB (insert_ (EventUpdatedPledge pledgeCreatedTs old_shares pledge_id))
eventInserterHandler (EDeletedPledge ts user_id project_id shares) = runDB (insert_ (EventDeletedPledge ts user_id project_id shares))
renderRoute' :: Route App -> App -> Text
renderRoute' route app =
......
......@@ -436,30 +436,54 @@ getProjectFeedR project_handle = do
before <- maybe (liftIO getCurrentTime) (return . read . T.unpack) =<< lookupGetParam "before"
(events, discussion_wiki_pages_map, wiki_pages_map, _) <- runYDB $ do
Entity project_id _ <- getBy404 (UniqueProjectHandle project_handle)
comment_posted_entities <- fetchProjectCommentsPostedOnWikiPagesBeforeDB project_id muser_id before
comment_pending_entities <- fetchProjectCommentsPendingBeforeDB project_id muser_id before
wiki_page_entities <- fetchProjectWikiPagesBeforeDB project_id before
wiki_edit_entities <- fetchProjectWikiEditsBeforeDB project_id before
new_pledge_entities <- fetchProjectNewPledgesBeforeDB project_id before
updated_pledges <- fetchProjectUpdatedPledgesBeforeDB project_id before
deleted_pledge_events <- fetchProjectDeletedPledgesBeforeDB project_id before
-- Suplementary maps for displaying the data.
-- 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 comments = map entityVal (comment_posted_entities <> comment_pending_entities)
wiki_edits = map entityVal wiki_edit_entities
pledges = map entityVal (new_pledge_entities <> (map snd updated_pledges))
-- WikiPages that can be keyed by a Comment's DiscussionId (i.e. the Comment *is* on a WikiPage)
discussion_wiki_pages_map <- M.fromList . map (\e@(Entity _ WikiPage{..}) -> (wikiPageDiscussion, e)) <$>
fetchDiscussionWikiPagesInDB (map commentDiscussion comments)
-- WikiPages keyed by their own IDs (contained in a WikiEdit)
wiki_pages_map <- entitiesMap <$> fetchWikiPagesInDB (map wikiEditPage wiki_edits)
users_map <- (<>)
-- All users: Comment posters, WikiPage creators, WikiEdit makers,
-- and Pledgers (new, updated, and deleted).
users_map <- (\a b c d -> a <> b <> c <> d)
<$> (entitiesMap <$> fetchUsersInDB (map commentUser comments))
<*> (entitiesMap <$> fetchUsersInDB (map wikiEditUser wiki_edits))
<*> (entitiesMap <$> fetchUsersInDB (map pledgeUser pledges))
<*> (entitiesMap <$> fetchUsersInDB (map (\(EventDeletedPledge _ user_id _ _) -> user_id) deleted_pledge_events))
let events = sortBy snowdriftEventNewestToOldest . mconcat $
[ map (onEntity ECommentPosted) comment_posted_entities
, map (onEntity ECommentPending) comment_pending_entities
, map (onEntity EWikiPage) wiki_page_entities
, map (onEntity EWikiEdit) wiki_edit_entities
, map (onEntity ENewPledge) new_pledge_entities
, map eup2se updated_pledges
, map edp2se deleted_pledge_events
]
return (events, discussion_wiki_pages_map, wiki_pages_map, users_map)
defaultLayout $(widgetFile "project_feed")
where
-- "event updated pledge to snowdrift event". Makes above code cleaner.
eup2se :: (Int64, Entity Pledge) -> SnowdriftEvent
eup2se (old_shares, Entity pledge_id pledge) = EUpdatedPledge old_shares pledge_id pledge
-- "event deleted pledge to snowdrift event". Makes above code cleaner.
edp2se :: EventDeletedPledge -> SnowdriftEvent
edp2se (EventDeletedPledge a b c d) = EDeletedPledge a b c d
......@@ -36,56 +36,33 @@ getUpdateSharesR project_handle = do
postUpdateSharesR :: Text -> Handler Html
postUpdateSharesR project_handle = do
user_id <- requireAuthId
((result, _), _) <- runFormPost $ confirmForm 1
now <- liftIO getCurrentTime
case result of
FormSuccess (SharesPurchaseOrder shares) -> do
-- TODO - refuse negative
Just pledge_render_id <- fmap (read . T.unpack) <$> lookupSession pledgeRenderKey
success <- runYDB $ do
Just user <- get user_id
Just account <- get $ userAccount user
Entity project_id _ <- getBy404 $ UniqueProjectHandle project_handle
_ <- insert $ SharesPledged now user_id shares pledge_render_id
either_unique <- insertBy $ Pledge user_id project_id shares shares
case either_unique of
Right _ -> return ()
Left (Entity pledge_id _) ->
if shares == 0
then delete $ from $ \ pledge -> where_ (pledge ^. PledgeId ==. val pledge_id)
else update $ \ pledge -> do
set pledge [ PledgeShares =. val shares
, PledgeFundedShares =. val shares
]
where_ (pledge ^. PledgeId ==. val pledge_id)
updateShareValue project_id
user_pledges <- rawSql
"SELECT ??, ?? FROM pledge JOIN project ON pledge.project = project.id WHERE pledge.\"user\" = ?;" [ unKey user_id ]
let user_outlay = sum $ map (\ (Entity _ pledge, Entity _ project) ->
projectShareValue project $* fromIntegral (pledgeShares pledge)) user_pledges :: Milray
success <- runSYDB $ do
Entity user_id user <- lift (lift requireAuth)
Just account <- lift $ get (userAccount user)
Entity project_id project <- lift $ getBy404 (UniqueProjectHandle project_handle)
let user_outlay = projectShareValue project $* fromIntegral shares :: Milray
if accountBalance account < user_outlay $* 3
then do
transactionUndo
return False
else return True
then return False
else do
insertProjectPledgeDB user_id project_id shares pledge_render_id
lift (updateShareValue project_id)
return True
if success
then addAlert "success" "you are now pledged to support this project"
else addAlert "warning"
"Sorry, you must have funds to support your pledge for at least 3 months at current share value. Please deposit additional funds to your account."
then addAlert "success" "you are now pledged to support this project"
else addAlert "warning"
"Sorry, you must have funds to support your pledge for at least 3 months at current share value. Please deposit additional funds to your account."
redirect $ ProjectR project_handle
redirect (ProjectR project_handle)
_ -> do
addAlert "danger" "error occurred in form submission"
redirect $ UpdateSharesR project_handle
......@@ -6,6 +6,10 @@ module Model.Project
, fetchProjectCommentsPostedOnWikiPagesBeforeDB
, fetchProjectWikiEditsBeforeDB
, fetchProjectWikiPagesBeforeDB
, fetchProjectNewPledgesBeforeDB
, fetchProjectUpdatedPledgesBeforeDB
, fetchProjectDeletedPledgesBeforeDB
, insertProjectPledgeDB
-- TODO(mitchell): rename all these... prefix fetch, suffix DB
, getGithubIssues
, getProjectPages
......@@ -26,6 +30,7 @@ import Model.Project.Sql
import Model.WikiPage.Sql
import Control.Monad.Trans.Resource (MonadThrow)
import Control.Monad.Writer.Strict (tell)
import Control.Concurrent.Async (Async, async, wait)
import qualified Github.Data as GH
import qualified Github.Issues as GH
......@@ -47,6 +52,31 @@ fetchProjectCommentIdsDB = fetchProjectCommentIdsPostedOnWikiPagesDB
fetchAllProjectsDB :: DB [Entity Project]
fetchAllProjectsDB = select (from return)
insertProjectPledgeDB :: UserId
-> ProjectId
-> Int64
-> PledgeFormRenderedId
-> SDB ()
insertProjectPledgeDB user_id project_id shares pledge_render_id = do
now <- liftIO getCurrentTime
lift $ insert_ (SharesPledged now user_id shares pledge_render_id)
let pledge = Pledge now user_id project_id shares shares
insertBy pledge >>= \case
Left (Entity pledge_id _) -> do
if shares == 0
then do
lift (deleteKey pledge_id)
tell [EDeletedPledge now user_id project_id shares]
else do
lift $
update $ \p -> do
set p [ PledgeShares =. val shares
, PledgeFundedShares =. val shares
]
where_ (p ^. PledgeId ==. val pledge_id)
tell [EUpdatedPledge shares pledge_id pledge]
Right pledge_id -> tell [ENewPledge pledge_id pledge]
getGithubIssues :: Project -> Handler [GH.Issue]
getGithubIssues project =
getGithubIssues'
......@@ -155,7 +185,7 @@ getProjectWikiPages project_id =
orderBy [asc (wp ^. WikiPageTarget)]
return wp
-- | Fetch all Comments posted on some Project's WikiPages before some time.
-- | Fetch all Comments posted on this Project's WikiPages before this time.
fetchProjectCommentsPostedOnWikiPagesBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> DB [Entity Comment]
fetchProjectCommentsPostedOnWikiPagesBeforeDB project_id muser_id before =
select $
......@@ -168,11 +198,11 @@ fetchProjectCommentsPostedOnWikiPagesBeforeDB project_id muser_id before =
exprPermissionFilter muser_id (val project_id) c
return c
-- | Fetch all CommentIds on some Project's WikiPages.
-- | Fetch all CommentIds on this Project's WikiPages.
fetchProjectCommentIdsPostedOnWikiPagesDB :: ProjectId -> DB [CommentId]
fetchProjectCommentIdsPostedOnWikiPagesDB = fmap (map unValue) . select . querProjectCommentIdsPostedOnWikiPagesDB
-- | Fetch all pending Comments made on a Project before some time.
-- | Fetch all pending Comments made on a Project before this time.
fetchProjectCommentsPendingBeforeDB :: ProjectId -> Maybe UserId -> UTCTime -> DB [Entity Comment]
fetchProjectCommentsPendingBeforeDB project_id muser_id before =
select $
......@@ -183,7 +213,7 @@ fetchProjectCommentsPendingBeforeDB project_id muser_id before =
exprPermissionFilter muser_id (val project_id) c
return c
-- | Fetch all WikiPages made on some Project before some time.
-- | Fetch all WikiPages made on this Project before this time.
fetchProjectWikiPagesBeforeDB :: ProjectId -> UTCTime -> DB [Entity WikiPage]
fetchProjectWikiPagesBeforeDB project_id before =
select $
......@@ -194,7 +224,7 @@ fetchProjectWikiPagesBeforeDB project_id before =
exprWikiPageOnProject wp project_id
return wp
-- | Fetch all WikiEdits made on some Project before some time.
-- | Fetch all WikiEdits made on this Project before this time.
fetchProjectWikiEditsBeforeDB :: ProjectId -> UTCTime -> DB [Entity WikiEdit]
fetchProjectWikiEditsBeforeDB project_id before =
select $
......@@ -205,3 +235,35 @@ fetchProjectWikiEditsBeforeDB project_id before =
ewe ^. EventWikiEditTs <=. val before &&.
exprWikiPageOnProject wp project_id
return we
-- | Fetch all new Pledges made on this Project before this time.
fetchProjectNewPledgesBeforeDB :: ProjectId -> UTCTime -> DB [Entity Pledge]
fetchProjectNewPledgesBeforeDB project_id before =
select $
from $ \(enp `InnerJoin` p) -> do
on_ (enp ^. EventNewPledgePledge ==. p ^. PledgeId)
where_ $
enp ^. EventNewPledgeTs <=. val before &&.
p ^. PledgeProject ==. val project_id
return p
-- | Fetch all updated Pledges made on this Project before this time, along with the old number of shares.
fetchProjectUpdatedPledgesBeforeDB :: ProjectId -> UTCTime -> DB [(Int64, Entity Pledge)]
fetchProjectUpdatedPledgesBeforeDB project_id before = fmap (map (\(Value n, p) -> (n, p))) $
select $
from $ \(eup `InnerJoin` p) -> do
on_ (eup ^. EventUpdatedPledgePledge ==. p ^. PledgeId)
where_ $
eup ^. EventUpdatedPledgeTs <=. val before &&.
p ^. PledgeProject ==. val project_id
return (eup ^. EventUpdatedPledgeOldShares, p)
-- | Fetch all deleted pledge events made on this Project before this time.
fetchProjectDeletedPledgesBeforeDB :: ProjectId -> UTCTime -> DB [EventDeletedPledge]
fetchProjectDeletedPledgesBeforeDB project_id before = fmap (map entityVal) $
select $
from $ \edp -> do
where_ $
edp ^. EventDeletedPledgeTs <=. val before &&.
edp ^. EventDeletedPledgeProject ==. val project_id
return edp
......@@ -8,8 +8,11 @@ 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
snowdriftEventTime (EWikiPage _ WikiPage{..}) = wikiPageCreatedTs
snowdriftEventTime (ECommentPosted _ Comment{..}) = fromMaybe commentCreatedTs commentModeratedTs
snowdriftEventTime (ECommentPending _ Comment{..}) = commentCreatedTs
snowdriftEventTime (EMessageSent _ Message{..}) = messageCreatedTs
snowdriftEventTime (EWikiEdit _ WikiEdit{..}) = wikiEditTs
snowdriftEventTime (EWikiPage _ WikiPage{..}) = wikiPageCreatedTs
snowdriftEventTime (ENewPledge _ Pledge{..}) = pledgeCreatedTs
snowdriftEventTime (EUpdatedPledge _ _ Pledge{..}) = pledgeCreatedTs
snowdriftEventTime (EDeletedPledge ts _ _ _) = ts
......@@ -4,10 +4,24 @@ module Model.SnowdriftEvent.Internal
import Model
import Data.Int (Int64)
import Data.Time (UTCTime)
-- A sum type of all events, each of which have their own database table.
data SnowdriftEvent
= ECommentPosted CommentId Comment -- Comment approved.
| ECommentPending CommentId Comment -- Comment unapproved (pending approval).
| EMessageSent MessageId Message
| EWikiEdit WikiEditId WikiEdit -- New WikiEdit made.
| EWikiPage WikiPageId WikiPage -- New WikiPage posted.
-- Comment approved.
= ECommentPosted CommentId Comment
-- Comment unapproved (pending approval).
| ECommentPending CommentId Comment
| EMessageSent MessageId Message
-- New WikiEdit made.
| EWikiEdit WikiEditId WikiEdit
-- New WikiPage posted.
| EWikiPage WikiPageId WikiPage
-- New pledge.
| ENewPledge PledgeId Pledge
-- Pledge that has changed in value.
| EUpdatedPledge Int64 {- old shares -}
PledgeId Pledge {- new pledge info -}
-- Deleted pledge.
| EDeletedPledge UTCTime UserId ProjectId Int64
......@@ -4,6 +4,10 @@ module View.SnowdriftEvent where
import Import
import Model.User
import Data.Map ((!))
renderCommentPostedOnWikiPageEvent :: CommentId -> Comment -> Entity WikiPage -> Widget
renderCommentPostedOnWikiPageEvent comment_id comment (Entity _ wiki_page) =
[whamlet|
......@@ -37,3 +41,25 @@ renderWikiEditEvent _ _ (Entity _ wiki_page) =
[whamlet|
<div>#{wikiPageTarget wiki_page} edit!
|]
renderNewPledgeEvent :: PledgeId -> Pledge -> UserMap -> Widget
renderNewPledgeEvent pledge_id Pledge{..} users_map = do
let pledger = users_map ! pledgeUser
[whamlet|
<div>#{userPrintName (Entity pledgeUser pledger)} pledged #{show pledgeShares} new shares!
|]
renderUpdatedPledgeEvent :: Int64 -> PledgeId -> Pledge -> UserMap -> Widget
renderUpdatedPledgeEvent old_shares pledge_id Pledge{..} users_map = do
let pledger = users_map ! pledgeUser
direction_text = if old_shares < pledgeShares then "down " else "up " :: Text
[whamlet|
<div>#{userPrintName (Entity pledgeUser pledger)} pledged #{show pledgeShares} shares! (#{direction_text} from #{show old_shares})
|]
renderDeletedPledgeEvent :: UserId -> Int64 -> UserMap -> Widget
renderDeletedPledgeEvent user_id shares users_map = do
let pledger = users_map ! user_id
[whamlet|
<div>#{userPrintName (Entity user_id pledger)} withdrew #{show shares}.
|]
......@@ -123,7 +123,11 @@ ProjectLastUpdate
update ProjectUpdateId
UniqueProjectLastUpdate project
-- Parts of Pledge are duplicated in EventDeletedPledge.
-- If you modify Pledge, be sure to (possibly) modify
-- EventDeletedPledge as well!
Pledge
createdTs UTCTime default=now()
user UserId
project ProjectId
shares Int64
......@@ -350,25 +354,40 @@ SharesPledged
-- An approved comment.
EventCommentPosted
comment CommentId
ts UTCTime
comment CommentId
-- An unapproved comment.
EventCommentPending
comment CommentId
ts UTCTime
comment CommentId
-- Message sent event.
EventMessageSent
message MessageId
ts UTCTime
message MessageId
-- Wiki page created event.
EventWikiPage
wikiPage WikiPageId
ts UTCTime
wikiPage WikiPageId
-- Wiki edit made event.
EventWikiEdit
ts UTCTime
wikiEdit WikiEditId
EventNewPledge
ts UTCTime
pledge PledgeId
EventUpdatedPledge
ts UTCTime
oldShares Int64
pledge PledgeId
EventDeletedPledge
ts UTCTime
user UserId
project ProjectId
shares Int64
ALTER TABLE "pledge" ADD COLUMN "created_ts" TIMESTAMP NOT NULL DEFAULT now();
ALTER TABLE "wiki_page" ADD COLUMN "created_ts" TIMESTAMP NOT NULL DEFAULT now();
CREATe TABLE "event_wiki_page"("id" SERIAL PRIMARY KEY UNIQUE,"wiki_page" INT8 NOT NULL,"ts" TIMESTAMP NOT NULL);
CREATe TABLE "event_wiki_page"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"wiki_page" INT8 NOT NULL);
ALTER TABLE "event_wiki_page" ADD CONSTRAINT "event_wiki_page_wiki_page_fkey" FOREIGN KEY("wiki_page") REFERENCES "wiki_page"("id");
CREATe TABLE "event_new_pledge"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"pledge" INT8 NOT NULL);
ALTER TABLE "event_new_pledge" ADD CONSTRAINT "event_new_pledge_pledge_fkey" FOREIGN KEY("pledge") REFERENCES "pledge"("id");
CREATe TABLE "event_updated_pledge"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"old_shares" INT8 NOT NULL,"pledge" INT8 NOT NULL);
ALTER TABLE "event_updated_pledge" ADD CONSTRAINT "event_updated_pledge_pledge_fkey" FOREIGN KEY("pledge") REFERENCES "pledge"("id");
CREATe TABLE "event_deleted_pledge"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"user" INT8 NOT NULL,"project" INT8 NOT NULL,"shares" INT8 NOT NULL);
ALTER TABLE "event_deleted_pledge" ADD CONSTRAINT "event_deleted_pledge_user_fkey" FOREIGN KEY("user") REFERENCES "user"("id");
ALTER TABLE "event_deleted_pledge" ADD CONSTRAINT "event_deleted_pledge_project_fkey" FOREIGN KEY("project") REFERENCES "project"("id");
......@@ -30,5 +30,14 @@ $forall event <- events
$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))}
$of ENewPledge pledge_id pledge
^{renderNewPledgeEvent pledge_id pledge users_map}
$of EUpdatedPledge old_shares pledge_id pledge
^{renderUpdatedPledgeEvent old_shares pledge_id pledge users_map}
$of EDeletedPledge _ user_id _ shares
^{renderDeletedPledgeEvent user_id shares users_map}
$of EMessageSent _ _
$# Don't display message events on project feeds.
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