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

Commit 58bc2474 authored by Mitchell Rosen's avatar Mitchell Rosen

beginning work on feed page

parent 83dd31d7
......@@ -13,19 +13,19 @@ import Version
import Blaze.ByteString.Builder (toLazyByteString)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (TChan, atomically, newTChanIO, tryReadTChan)
import Control.Concurrent.STM (atomically, newTChanIO, tryReadTChan)
import Control.Monad.Logger (runLoggingT, runStderrLoggingT)
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Data.Default (def)
import qualified Data.List as L
import Data.Maybe (fromJust)
import Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import qualified Data.Text.IO as T
import qualified Database.Persist
import Database.Persist (getJust)
import Database.Persist.Postgresql (pgConnStr, withPostgresqlConn)
import Network.HTTP.Client.Conduit (newManager)
import Network.Wai.Middleware.RequestLogger ( mkRequestLogger, outputFormat, OutputFormat (..)
......@@ -75,7 +75,7 @@ import Handler.Wiki
import Handler.Wiki.Comment
import Model.Message
import Model.SnowdriftEvent
import Model.SnowdriftEvent.Internal
import Model.User
import Widgets.Navbar
......@@ -160,7 +160,10 @@ makeFoundation conf = do
dbconf
logger
event_chan
[messageEventHandler] -- Add more event handlers here.
-- Add more event handlers here.
[ messageEventHandler
, eventInserterHandler
]
-- Perform database migration using our application's logging settings.
case appEnv conf of
......@@ -356,15 +359,17 @@ forkEventHandler app@App{..} = void . forkIO . forever $ do
mapM_ (runDaemon app) (appEventHandlers <*> [event])
handleNEvents (n-1)
-- Handler in charge of sending Messages to interested parties.
-- | Handler in charge of sending Messages to interested parties.
messageEventHandler :: SnowdriftEvent -> Daemon ()
messageEventHandler (ECommentPosted comment_id comment) = case commentParent comment of
Nothing -> return ()
Just parent_comment_id -> do
(parent_user_id, parent_user) <- runDB $ do
parent_user_id <- commentUser <$> getJust parent_comment_id
(parent_user_id,) <$> getJust parent_user_id
when (MessageOnReply `elem` userMessagePreferences parent_user) $ do
(parent_user_id, delivery) <- runDB $ do
parent_user_id <- commentUser <$> Database.Persist.getJust parent_comment_id
delivery <- fetchUserMessagePrefDB parent_user_id MessageReply
return (parent_user_id, delivery)
-- Any non-Nothing delivery implies an internal Message should be sent.
when (isJust delivery) $ do
app <- ask
let parent_comment_route = renderRoute' (CommentDirectLinkR parent_comment_id) app
reply_comment_route = renderRoute' (CommentDirectLinkR comment_id) app
......@@ -378,10 +383,17 @@ messageEventHandler (ECommentPosted comment_id comment) = case commentParent com
, ""
, "*You can filter these messages by adjusting the settings in your profile.*"
]
now <- liftIO getCurrentTime
runSDB $ insertMessage_ (Message MessageReply Nothing now Nothing (Just parent_user_id) content True)
runSDB $ insertMessage_ MessageReply Nothing Nothing (Just parent_user_id) content True
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 (EWikiEdit wiki_edit_id WikiEdit{..}) = runDB (insert_ (EventWikiEdit wiki_edit_id wikiEditTs))
renderRoute' :: Route App -> App -> Text
renderRoute' route app =
let (path_pieces, query_params) = renderRoute route
......
......@@ -3,9 +3,8 @@ module Foundation where
import Model
import Model.Currency
import Model.Established.Internal (Established(..))
import Model.Message.Internal (MessageType(..))
import Model.SnowdriftEvent
import Model.User.Internal (MessagePreference(..))
import Model.Message.Internal (MessageType(..), MessageDelivery(..))
import Model.SnowdriftEvent.Internal
import qualified Settings
import Settings (widgetFile, Extra (..))
import Settings.Development (development)
......@@ -349,7 +348,7 @@ createUser ident passwd name avatar nick = do
now <- liftIO getCurrentTime
handle (\DBException -> return Nothing) $ runYDB $ do
account_id <- insert $ Account 0
user <- maybe return setPassword passwd $ User ident (Just now) Nothing Nothing name account_id avatar Nothing Nothing nick now now now now EstUnestablished [MessageOnReply]
user <- maybe return setPassword passwd $ User ident (Just now) Nothing Nothing name account_id avatar Nothing Nothing nick now now EstUnestablished
uid_maybe <- insertUnique user
Entity snowdrift_id _ <- getBy404 $ UniqueProjectHandle "snowdrift"
case uid_maybe of
......@@ -363,6 +362,8 @@ createUser ident passwd name avatar nick = do
forM_ default_tag_colors $ \ (Entity _ (DefaultTagColor tag color)) -> insert $ TagColor tag user_id color
--
insertDefaultMessagePrefs user_id
let message_text = Markdown $ T.unlines
[ "Thanks for registering!"
, "<br> Please read our [**welcome message**](/p/snowdrift/w/welcome), and let us know any questions."
......@@ -374,7 +375,9 @@ createUser ident passwd name avatar nick = do
Nothing -> do
lift $ addAlert "danger" "E-mail or handle already in use."
throwIO DBException
where
insertDefaultMessagePrefs :: UserId -> DB ()
insertDefaultMessagePrefs user_id = insert_ $ UserMessagePref user_id MessageReply DeliverInternal
instance YesodJquery App
......
......@@ -20,7 +20,6 @@ getContactR project_handle = do
postContactR :: Text -> Handler Html
postContactR project_handle = do
maybe_user_id <- maybeAuthId
now <- liftIO getCurrentTime
((result, _), _) <- runFormPost contactForm
......@@ -28,7 +27,7 @@ postContactR project_handle = do
FormSuccess content -> do
runSYDB $ do
Entity project_id _ <- lift $ getBy404 $ UniqueProjectHandle project_handle
insertMessage_ $ Message MessageDirect (Just project_id) now maybe_user_id Nothing content False
insertMessage_ MessageDirect (Just project_id) maybe_user_id Nothing content False
addAlert "success" "Comment submitted. Thank you for your input!"
......
......@@ -7,42 +7,30 @@ import Import
import Model.Currency
import Model.Project
import Model.Shares
import Model.Markdown
import Model.Markdown.Diff
import Model.User
import View.PledgeButton
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Set as S
import Data.Maybe (maybeToList)
import Widgets.Markdown
import Widgets.Preview
import Widgets.Time
import Model.Markdown
import Yesod.Markdown
import Data.Time.Clock
import Data.List (sort)
import qualified Data.Map as M
import Data.Maybe (fromJust, maybeToList)
import qualified Data.Text as T
import Data.Time.Clock
import qualified Data.Set as S
import Yesod.Markdown
lookupGetParamDefault :: Read a => Text -> a -> Handler a
lookupGetParamDefault name def = do
maybe_value <- lookupGetParam name
return $ fromMaybe def $ maybe_value >>= readMaybe . T.unpack
getProjectsR :: Handler Html
getProjectsR = do
muser <- maybeAuth
projects <- runDB $ select $ from return
counts <- runDB $ maybe (const $ return []) getCounts muser projects
let counts' = M.fromList $ zip (map entityKey projects) counts
projects <- runDB getAllProjects
defaultLayout $ do
setTitle "Projects | Snowdrift.coop"
......@@ -419,3 +407,48 @@ renderBlogPost project_handle blog_post = do
content = markdownWidget project_handle $ Markdown $ T.snoc top_content '\n' <> bottom_content
$(widgetFile "blog_post")
postWatchProjectR :: ProjectId -> Handler ()
postWatchProjectR = undefined -- TODO(mitchell)
postUnwatchProjectR :: ProjectId -> Handler ()
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
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)
defaultLayout $(widgetFile "project_feed")
This diff is collapsed.
......@@ -6,11 +6,10 @@ import Model.Comment.Internal (ClosureType, FlagReason)
import Model.Currency (Milray)
import Model.Established.Internal (Established(..))
import Model.Markdown.Diff (MarkdownDiff)
import Model.Message.Internal (MessageType)
import Model.Message.Internal (MessageType, MessageDelivery)
import Model.Permission.Internal (PermissionLevel)
import Model.Role.Internal (Role)
import Model.Settings.Internal (UserSettingName)
import Model.User.Internal (MessagePreference)
import Model.ViewType.Internal (ViewType)
import Control.Exception (Exception)
......
......@@ -45,18 +45,13 @@ module Model.Comment
, newRetractedCommentClosure
, rethreadComments
, subGetCommentAncestors
-- SQL expressions/queries
, exprPermissionFilter
, exprUnapproved
-- Probably shouldn't be exported
, makeViewerInfo
) where
import Import
import Model.Comment.Sql
import Model.Message
import Model.SnowdriftEvent
import Model.User (isProjectModerator')
import Model.SnowdriftEvent.Internal
import qualified Control.Monad.State as St
import Control.Monad.Writer.Strict (tell)
......@@ -216,18 +211,9 @@ editComment comment_id text = do
comment_id
permalink_text <- lift $ getUrlRender <*> pure permalink_route
let message_text = Markdown $ "A comment you flagged has been edited and reposted to the site. You can view it [here](" <> permalink_text <> ")."
now <- liftIO getCurrentTime
lift $ deleteCascade comment_flagging_id -- delete flagging and all flagging reasons with it.
snowdrift_id <- lift getSnowdriftId
insertMessage_ $
Message
MessageDirect
(Just snowdrift_id)
now
Nothing
(Just $ commentFlaggingFlagger)
message_text
True
insertMessage_ MessageDirect (Just snowdrift_id) Nothing (Just $ commentFlaggingFlagger) message_text True
where
updateCommentText =
update $ \c -> do
......@@ -255,15 +241,7 @@ flagComment project_handle target comment_id permalink_route flagger_id reasons
, "[link to flagged comment](" <> permalink_route <> ")"
]
snowdrift_id <- lift getSnowdriftId
insertMessage_ $
Message
MessageDirect
(Just snowdrift_id)
now
Nothing
(Just poster_id)
message_text
True
insertMessage_ MessageDirect (Just snowdrift_id) Nothing (Just poster_id) message_text True
return True
-- | Get all ancestors that have been closed.
......@@ -347,24 +325,24 @@ getCommentDescendantsIds = fmap (map unValue) . select . querDescendants
-- | Get all descendants of the given root comment.
getCommentDescendants :: Maybe UserId -> ProjectId -> CommentId -> DB [Entity Comment]
getCommentDescendants mviewer_id project_id root_id = makeViewerInfo mviewer_id project_id >>= \viewer_info ->
getCommentDescendants mviewer_id project_id root_id =
select $
from $ \c -> do
where_ $
c ^. CommentId `in_` subList_select (querDescendants root_id) &&.
exprPermissionFilter viewer_info c
exprPermissionFilter mviewer_id (val project_id) c
-- DO NOT change ordering here! buildCommentTree relies on it.
orderBy [asc (c ^. CommentParent), asc (c ^. CommentCreatedTs)]
return c
-- | Get all descendants of all given root comments.
getCommentsDescendants :: Maybe UserId -> ProjectId -> [CommentId] -> DB [Entity Comment]
getCommentsDescendants mviewer_id project_id root_ids = makeViewerInfo mviewer_id project_id >>= \viewer_info ->
getCommentsDescendants mviewer_id project_id root_ids =
select $
from $ \c -> do
where_ $
c ^. CommentId `in_` subList_select (querAllDescendants root_ids) &&.
exprPermissionFilter viewer_info c
exprPermissionFilter mviewer_id (val project_id) c
-- DO NOT change ordering here! buildCommentTree relies on it.
orderBy [asc (c ^. CommentParent), asc (c ^. CommentCreatedTs)]
return c
......@@ -378,35 +356,35 @@ getCommentDestination comment_id = do
-- | Get all Comments on a Discussion that are root comments.
getAllRootComments :: Maybe UserId -> ProjectId -> DiscussionId -> DB [Entity Comment]
getAllRootComments mviewer_id project_id discussion_id = makeViewerInfo mviewer_id project_id >>= \viewer_info ->
getAllRootComments mviewer_id project_id discussion_id =
select $
from $ \c -> do
where_ $
exprOnDiscussion discussion_id c &&.
exprRoot c &&.
exprPermissionFilter viewer_info c
exprPermissionFilter mviewer_id (val project_id) c
return c
getAllClosedRootComments :: Maybe UserId -> ProjectId -> DiscussionId -> DB [Entity Comment]
getAllClosedRootComments mviewer_id project_id discussion_id = makeViewerInfo mviewer_id project_id >>= \viewer_info ->
getAllClosedRootComments mviewer_id project_id discussion_id =
select $
from $ \c -> do
where_ $
exprOnDiscussion discussion_id c &&.
exprRoot c &&.
exprClosed c &&.
exprPermissionFilter viewer_info c
exprPermissionFilter mviewer_id (val project_id) c
return c
getAllOpenRootComments :: Maybe UserId -> ProjectId -> DiscussionId -> DB [Entity Comment]
getAllOpenRootComments mviewer_id project_id discussion_id = makeViewerInfo mviewer_id project_id >>= \viewer_info ->
getAllOpenRootComments mviewer_id project_id discussion_id =
select $
from $ \c -> do
where_ $
exprOnDiscussion discussion_id c &&.
exprRoot c &&.
exprOpen c &&.
exprPermissionFilter viewer_info c
exprPermissionFilter mviewer_id (val project_id) c
return c
-- | Get a Comment's Tags.
......@@ -518,94 +496,3 @@ rethreadComments rethread_id depth_offset maybe_new_parent_id new_discussion_id
<&> (comment_rethread ^. CommentRethreadNewComment)
return new_comment_ids
-- | Dumb helper function to make a "viewer info" argument for exprPermissionFilter.
-- Unfortunately we export it as another module uses exprPermissionFilter. Probably
-- this should be rectified.
makeViewerInfo :: Maybe UserId -> ProjectId -> DB (Maybe (UserId, Bool))
makeViewerInfo Nothing _ = return Nothing
makeViewerInfo (Just viewer_id) project_id = Just . (viewer_id,) <$> isProjectModerator' viewer_id project_id
--------------------------------------------------------------------------------
exprClosed, exprOpen :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprClosed c = c ^. CommentId `in_` exprClosedCommentIds
exprOpen c = c ^. CommentId `notIn` exprClosedCommentIds
exprClosedCommentIds :: SqlExpr (ValueList CommentId)
exprClosedCommentIds =
subList_select $
from $ \cl ->
return (cl ^. CommentClosureComment)
-- | Comment is root?
exprRoot :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprRoot c = isNothing (c ^. CommentParent)
-- | Comment on this Discussion?
exprOnDiscussion :: DiscussionId -> SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprOnDiscussion discussion_id c = c ^. CommentDiscussion ==. val discussion_id
-- | SQL expression to filter a comment based on "permissions", as follows:
-- If moderator, show all.
-- 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).
--
-- The logic here is DUPLICATED (in Haskell land) in Handler.Wiki.Comment.checkCommentPage
-- (because that function only fetches the root comment via Database.Persist.get) - all
-- changes here must be reflected there, too!
exprPermissionFilter :: Maybe (UserId, Bool) -- Logged in? And if so, moderator?
-> SqlExpr (Entity Comment)
-> SqlExpr (Value Bool)
exprPermissionFilter (Just (_,True)) c = exprNotRethreaded c
exprPermissionFilter (Just (viewer_id,_)) c = exprNotRethreaded c &&. (exprApprovedAndNotFlagged c ||. exprPostedBy viewer_id c)
exprPermissionFilter Nothing c = exprNotRethreaded c &&. exprApprovedAndNotFlagged c
exprNotRethreaded :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprNotRethreaded c = c ^. CommentId `notIn` rethreadedCommentIds
where
rethreadedCommentIds :: SqlExpr (ValueList CommentId)
rethreadedCommentIds =
subList_select $
from $ \r ->
return (r ^. RethreadOldComment)
exprApproved :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprApproved = not_ . exprUnapproved
exprUnapproved :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprUnapproved c = isNothing (c ^. CommentModeratedTs)
exprNotFlagged :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprNotFlagged c = c ^. CommentId `notIn` flaggedCommentIds
where
flaggedCommentIds :: SqlExpr (ValueList CommentId)
flaggedCommentIds =
subList_select $
from $ \cf ->
return (cf ^. CommentFlaggingComment)
exprApprovedAndNotFlagged :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprApprovedAndNotFlagged c = exprApproved c &&. exprNotFlagged c
exprPostedBy :: UserId -> SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprPostedBy user_id c = c ^. CommentUser ==. val user_id
querAncestors :: CommentId -> SqlQuery (SqlExpr (Value CommentId))
querAncestors comment_id =
from $ \ca -> do
where_ (ca ^. CommentAncestorComment ==. val comment_id)
return (ca ^. CommentAncestorAncestor)
querDescendants :: CommentId -> SqlQuery (SqlExpr (Value CommentId))
querDescendants comment_id =
from $ \ca -> do
where_ (ca ^. CommentAncestorAncestor ==. val comment_id)
return (ca ^. CommentAncestorComment)
querAllDescendants :: [CommentId] -> SqlQuery (SqlExpr (Value CommentId))
querAllDescendants comment_ids =
from $ \ca -> do
where_ (ca ^. CommentAncestorAncestor `in_` valList comment_ids)
return (ca ^. CommentAncestorComment)
module Model.Comment.Sql where
import Import
import Model.User.Sql (exprIsModerator)
exprClosed, exprOpen :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprClosed c = c ^. CommentId `in_` exprClosedCommentIds
exprOpen c = c ^. CommentId `notIn` exprClosedCommentIds
exprClosedCommentIds :: SqlExpr (ValueList CommentId)
exprClosedCommentIds =
subList_select $
from $ \cl ->
return (cl ^. CommentClosureComment)
-- | Comment is root?
exprRoot :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprRoot c = isNothing (c ^. CommentParent)
-- | Comment on this Discussion?
exprOnDiscussion :: DiscussionId -> SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprOnDiscussion discussion_id c = c ^. CommentDiscussion ==. val discussion_id
-- | SQL expression to filter a comment based on "permissions", as follows:
-- If moderator, show all.
-- 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).
--
-- The logic here is DUPLICATED (in Haskell land) in Handler.Wiki.Comment.checkCommentPage
-- (because that function only fetches the root comment via Database.Persist.get) - all
-- changes here must be reflected there, too!
exprPermissionFilter :: Maybe UserId
-> SqlExpr (Value ProjectId)
-> SqlExpr (Entity Comment)
-> SqlExpr (Value Bool)
exprPermissionFilter muser_id project_id c = exprNotRethreaded c &&. permissionFilter
where
permissionFilter :: SqlExpr (Value Bool)
permissionFilter = case muser_id of
Just user_id -> exprApprovedAndNotFlagged c ||. exprPostedBy user_id c ||. exprIsModerator user_id project_id
Nothing -> exprApprovedAndNotFlagged c
exprNotRethreaded :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprNotRethreaded c = c ^. CommentId `notIn` rethreadedCommentIds
where
rethreadedCommentIds :: SqlExpr (ValueList CommentId)
rethreadedCommentIds =
subList_select $
from $ \r ->
return (r ^. RethreadOldComment)
exprApproved :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprApproved = not_ . exprUnapproved
exprUnapproved :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprUnapproved c = isNothing (c ^. CommentModeratedTs)
exprNotFlagged :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprNotFlagged c = c ^. CommentId `notIn` flaggedCommentIds
where
flaggedCommentIds :: SqlExpr (ValueList CommentId)
flaggedCommentIds =
subList_select $
from $ \cf ->
return (cf ^. CommentFlaggingComment)
exprApprovedAndNotFlagged :: SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprApprovedAndNotFlagged c = exprApproved c &&. exprNotFlagged c
exprPostedBy :: UserId -> SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprPostedBy user_id c = c ^. CommentUser ==. val user_id
exprCommentViewedBy :: UserId -> SqlExpr (Entity Comment) -> SqlExpr (Value Bool)
exprCommentViewedBy user_id c = c ^. CommentId `in_`
(subList_select $
from $ \vc -> do
where_ (vc ^. ViewCommentUser ==. val user_id)
return (vc ^. ViewCommentComment))
querAncestors :: CommentId -> SqlQuery (SqlExpr (Value CommentId))
querAncestors comment_id =
from $ \ca -> do
where_ (ca ^. CommentAncestorComment ==. val comment_id)
return (ca ^. CommentAncestorAncestor)
querDescendants :: CommentId -> SqlQuery (SqlExpr (Value CommentId))
querDescendants comment_id =
from $ \ca -> do
where_ (ca ^. CommentAncestorAncestor ==. val comment_id)
return (ca ^. CommentAncestorComment)
querAllDescendants :: [CommentId] -> SqlQuery (SqlExpr (Value CommentId))
querAllDescendants comment_ids =
from $ \ca -> do
where_ (ca ^. CommentAncestorAncestor `in_` valList comment_ids)
return (ca ^. CommentAncestorComment)
......@@ -6,15 +6,29 @@ module Model.Message
import Import
import Model.Message.Internal
import Model.SnowdriftEvent
import Model.SnowdriftEvent.Internal
import Control.Monad.Writer.Strict (tell)
insertMessage :: Message -> SDB MessageId
insertMessage message = do
message_id <- lift $ insert message
tell [EMessageSent message_id]
insertMessage :: MessageType
-> Maybe ProjectId
-> Maybe UserId
-> Maybe UserId
-> Markdown
-> Bool
-> SDB MessageId
insertMessage message_type mproject_id mfrom mto content is_automated = do
now <- liftIO getCurrentTime
let message = Message message_type mproject_id now mfrom mto content is_automated
message_id <- lift (insert message)
tell [EMessageSent message_id message]
return message_id
insertMessage_ :: Message -> SDB ()
insertMessage_ = void . insertMessage
insertMessage_ :: MessageType
-> Maybe ProjectId
-> Maybe UserId
-> Maybe UserId
-> Markdown
-> Bool
-> SDB ()
insertMessage_ a b c d e f = void $ insertMessage a b c d e f
......@@ -3,13 +3,30 @@ module Model.Message.Internal where
import Prelude
import Database.Persist.TH
import Data.Text (Text)
data MessageType
= MessageDirect -- Direct message (can't be ignored)
| MessageBalanceLow -- Balance low (can't be ignored)
| MessageReply -- Reply to a comment made.
| MessageNewProject
-- Project scope
| MessageNewPledger
| MessageNewPage
deriving (Read, Show)
derivePersistField "MessageType"
showMessageType :: MessageType -> Text
showMessageType MessageDirect = "Snowdrift direct messages"