In ticket comment tree, support mixing local and remote (federated) comments

This commit is contained in:
fr33domlover 2019-03-20 08:07:37 +00:00
parent e0de4cdcc7
commit 716487f2b8
11 changed files with 213 additions and 79 deletions

View file

@ -220,12 +220,23 @@ TicketClaimRequest
Discussion Discussion
Message Message
author PersonId
created UTCTime created UTCTime
content Text -- Assume this is Pandoc Markdown content Text -- Assume this is Pandoc Markdown
parent MessageId Maybe parent MessageId Maybe
root DiscussionId root DiscussionId
LocalMessage
author PersonId
rest MessageId
UniqueLocalMessage rest
RemoteMessage
author RemoteSharerId
rest MessageId
UniqueRemoteMessage rest
RepoCollab RepoCollab
repo RepoId repo RepoId
person PersonId person PersonId

View file

@ -0,0 +1,20 @@
-- This file is used for generating a Persistent entity for the 2019 Message,
-- which we use it for the SQL query that moves the author field to a separate
-- table.
Person
Discussion
Message
author PersonId
created UTCTime
content Text -- Assume this is Pandoc Markdown
parent MessageId Maybe
root DiscussionId
LocalMessage
author PersonId
rest MessageId
UniqueLocalMessage rest

View file

@ -0,0 +1,11 @@
LocalMessage
author PersonId
rest MessageId
UniqueLocalMessage rest
RemoteMessage
author RemoteSharerId
rest MessageId
UniqueRemoteMessage rest

View file

@ -14,7 +14,9 @@
-} -}
module Vervis.Discussion module Vervis.Discussion
( getDiscussionTree ( MessageTreeNodeAuthor (..)
, MessageTreeNode (..)
, getDiscussionTree
) )
where where
@ -31,41 +33,66 @@ import Yesod.Persist.Core (runDB)
import qualified Data.HashMap.Lazy as M (fromList, lookup) import qualified Data.HashMap.Lazy as M (fromList, lookup)
import Network.FedURI
import Data.Tree.Local (sortForestOn) import Data.Tree.Local (sortForestOn)
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
getMessages :: AppDB DiscussionId -> Handler [(Entity Message, Sharer)] data MessageTreeNodeAuthor
getMessages getdid = fmap (map $ second entityVal) $ runDB $ do = MessageTreeNodeLocal LocalMessageId Sharer
did <- getdid | MessageTreeNodeRemote FedURI
select $ from $ \ (message, person, sharer) -> do
where_ $
message ^. MessageRoot ==. val did &&.
message ^. MessageAuthor ==. person ^. PersonId &&.
person ^. PersonIdent ==. sharer ^. SharerId
return (message, sharer)
discussionTree :: [(Entity Message, Sharer)] -> Forest (Entity Message, Sharer) data MessageTreeNode = MessageTreeNode
{ mtnMessageId :: MessageId
, mtnMessage :: Message
, mtnAuthor :: MessageTreeNodeAuthor
}
getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode]
getMessages getdid = runDB $ do
did <- getdid
l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` p `InnerJoin` s) -> do
on $ p ^. PersonIdent ==. s ^. SharerId
on $ lm ^. LocalMessageAuthor ==. p ^. PersonId
on $ lm ^. LocalMessageRest ==. m ^. MessageId
where_ $ m ^. MessageRoot ==. val did
return (m, lm ^. LocalMessageId, s)
r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` rs `InnerJoin` i) -> do
on $ rs ^. RemoteSharerInstance ==. i ^. InstanceId
on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteSharerId
on $ rm ^. RemoteMessageRest ==. m ^. MessageId
where_ $ m ^. MessageRoot ==. val did
return (m, i ^. InstanceHost, rs ^. RemoteSharerIdent)
return $ map mklocal l ++ map mkremote r
where
mklocal (Entity mid m, Value lmid, Entity _ s) =
MessageTreeNode mid m $ MessageTreeNodeLocal lmid s
mkremote (Entity mid m, Value h, Value lu) =
MessageTreeNode mid m $ MessageTreeNodeRemote $ l2f h lu
discussionTree :: [MessageTreeNode] -> Forest MessageTreeNode
discussionTree mss = discussionTree mss =
let nodes = zip [1..] mss let nodes = zip [1..] mss
mkEntry n ((Entity mid _m), _s) = (mid, n) mkEntry n mtn = (mtnMessageId mtn, n)
nodeMap = M.fromList $ map (uncurry mkEntry) nodes nodeMap = M.fromList $ map (uncurry mkEntry) nodes
mkEdge n (Entity _ m, _s) = mkEdge n mtn =
case messageParent m of case messageParent $ mtnMessage mtn of
Nothing -> Nothing Nothing -> Nothing
Just mid -> Just mid ->
case M.lookup mid nodeMap of case M.lookup mid nodeMap of
Nothing -> error "message parent not in discussion" Nothing -> error "message parent not in discussion"
Just p -> Just (p, n, ()) Just p -> Just (p, n, ())
edges = mapMaybe (uncurry mkEdge) nodes edges = mapMaybe (uncurry mkEdge) nodes
graph = mkGraph nodes edges :: Gr (Entity Message, Sharer) () graph = mkGraph nodes edges :: Gr MessageTreeNode ()
roots = [n | (n, (Entity _ m, _s)) <- nodes, isNothing $ messageParent m] roots =
[n | (n, mtn) <- nodes, isNothing $ messageParent $ mtnMessage mtn]
in dffWith lab' roots graph in dffWith lab' roots graph
sortByTime :: Forest (Entity Message, Sharer) -> Forest (Entity Message, Sharer) sortByTime :: Forest MessageTreeNode -> Forest MessageTreeNode
sortByTime = sortForestOn $ messageCreated . entityVal . fst sortByTime = sortForestOn $ messageCreated . mtnMessage
-- | Get the tree of messages in a given discussion, with siblings sorted from -- | Get the tree of messages in a given discussion, with siblings sorted from
-- old to new. -- old to new.
getDiscussionTree :: AppDB DiscussionId -> Handler (Forest (Entity Message, Sharer)) getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode)
getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid

View file

@ -37,6 +37,9 @@ import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..)) import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404) import Yesod.Persist.Core (runDB, get404, getBy404)
import Network.FedURI
import Vervis.Discussion
import Vervis.Form.Discussion import Vervis.Form.Discussion
import Vervis.Foundation (App, Handler, AppDB) import Vervis.Foundation (App, Handler, AppDB)
import Vervis.Model import Vervis.Model
@ -51,21 +54,36 @@ getDiscussion
getDiscussion reply topic getdid = getDiscussion reply topic getdid =
defaultLayout $ discussionW getdid topic reply defaultLayout $ discussionW getdid topic reply
getNode :: AppDB DiscussionId -> MessageId -> AppDB MessageTreeNode
getNode getdid mid = do
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
mlocal <- getBy $ UniqueLocalMessage mid
mremote <- getBy $ UniqueRemoteMessage mid
author <- case (mlocal, mremote) of
(Nothing, Nothing) -> fail "Message with no author"
(Just _, Just _) -> fail "Message used as both local and remote"
(Just (Entity lmid lm), Nothing) -> do
p <- getJust $ localMessageAuthor lm
s <- getJust $ personIdent p
return $ MessageTreeNodeLocal lmid s
(Nothing, Just (Entity _rmid rm)) -> do
rs <- getJust $ remoteMessageAuthor rm
i <- getJust $ remoteSharerInstance rs
return $ MessageTreeNodeRemote $
l2f (instanceHost i) (remoteSharerIdent rs)
return $ MessageTreeNode mid m author
getDiscussionMessage getDiscussionMessage
:: (MessageId -> Route App) :: (MessageId -> Route App)
-> AppDB DiscussionId -> AppDB DiscussionId
-> MessageId -> MessageId
-> Handler Html -> Handler Html
getDiscussionMessage reply getdid mid = do getDiscussionMessage reply getdid mid = do
(msg, shr) <- runDB $ do mtn <- runDB $ getNode getdid mid
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
defaultLayout $ messageW now shr (Entity mid msg) reply defaultLayout $ messageW now mtn reply
getTopReply :: Route App -> Handler Html getTopReply :: Route App -> Handler Html
getTopReply replyP = do getTopReply replyP = do
@ -74,7 +92,7 @@ getTopReply replyP = do
postTopReply postTopReply
:: Route App :: Route App
-> (MessageId -> Route App) -> (LocalMessageId -> Route App)
-> AppDB DiscussionId -> AppDB DiscussionId
-> Handler Html -> Handler Html
postTopReply replyP after getdid = do postTopReply replyP after getdid = do
@ -85,14 +103,17 @@ postTopReply replyP after getdid = do
author <- requireAuthId author <- requireAuthId
mnum <- runDB $ do mnum <- runDB $ do
did <- getdid did <- getdid
let message = Message mid <- insert Message
{ messageAuthor = author { messageCreated = now
, messageCreated = now
, messageContent = nmContent nm , messageContent = nmContent nm
, messageParent = Nothing , messageParent = Nothing
, messageRoot = did , messageRoot = did
} }
insert message lmid <- insert LocalMessage
{ localMessageAuthor = author
, localMessageRest = mid
}
return lmid
setMessage "Message submitted." setMessage "Message submitted."
redirect $ after mnum redirect $ after mnum
FormMissing -> do FormMissing -> do
@ -109,13 +130,7 @@ getReply
-> MessageId -> MessageId
-> Handler Html -> Handler Html
getReply replyG replyP getdid mid = do getReply replyG replyP getdid mid = do
(msg, shr) <- runDB $ do mtn <- runDB $ getNode getdid mid
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
((_result, widget), enctype) <- runFormPost newMessageForm ((_result, widget), enctype) <- runFormPost newMessageForm
defaultLayout $(widgetFile "discussion/reply") defaultLayout $(widgetFile "discussion/reply")
@ -123,7 +138,7 @@ getReply replyG replyP getdid mid = do
postReply postReply
:: (MessageId -> Route App) :: (MessageId -> Route App)
-> (MessageId -> Route App) -> (MessageId -> Route App)
-> (MessageId -> Route App) -> (LocalMessageId -> Route App)
-> AppDB DiscussionId -> AppDB DiscussionId
-> MessageId -> MessageId
-> Handler Html -> Handler Html
@ -139,33 +154,24 @@ postReply replyG replyP after getdid mid = do
message <- get404 mid message <- get404 mid
unless (messageRoot message == did) notFound unless (messageRoot message == did) notFound
return mid return mid
let message = Message mid <- insert Message
{ messageAuthor = author { messageCreated = now
, messageCreated = now
, messageContent = nmContent nm , messageContent = nmContent nm
, messageParent = Just parent , messageParent = Just parent
, messageRoot = did , messageRoot = did
} }
insert message lmid <- insert LocalMessage
{ localMessageAuthor = author
, localMessageRest = mid
}
return lmid
setMessage "Message submitted." setMessage "Message submitted."
redirect $ after msgid redirect $ after msgid
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing." setMessage "Field(s) missing."
(msg, shr) <- runDB $ do mtn <- runDB $ getNode getdid mid
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
defaultLayout $(widgetFile "discussion/reply") defaultLayout $(widgetFile "discussion/reply")
FormFailure _l -> do FormFailure _l -> do
setMessage "Message submission failed, see errors below." setMessage "Message submission failed, see errors below."
(msg, shr) <- runDB $ do mtn <- runDB $ getNode getdid mid
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
defaultLayout $(widgetFile "discussion/reply") defaultLayout $(widgetFile "discussion/reply")

View file

@ -38,7 +38,7 @@ import Database.Persist
import Database.Persist.BackendDataType (backendDataType, PersistDefault (..)) import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
import Database.Persist.Migration import Database.Persist.Migration
import Database.Persist.Schema (SchemaT, Migration) import Database.Persist.Schema (SchemaT, Migration)
import Database.Persist.Schema.Types import Database.Persist.Schema.Types hiding (Entity)
import Database.Persist.Schema.PostgreSQL (schemaBackend) import Database.Persist.Schema.PostgreSQL (schemaBackend)
import Database.Persist.Sql (SqlBackend, toSqlKey) import Database.Persist.Sql (SqlBackend, toSqlKey)
--import Text.Email.QuasiQuotation (email --import Text.Email.QuasiQuotation (email
@ -191,14 +191,23 @@ changes =
, addEntities model_2019_02_03_verifkey , addEntities model_2019_02_03_verifkey
-- 42 -- 42
, unchecked $ lift $ do , unchecked $ lift $ do
deleteWhere ([] :: [Filter (VerifKeySharedUsage2019Generic SqlBackend)]) deleteWhere ([] :: [Filter VerifKeySharedUsage2019])
deleteWhere ([] :: [Filter (VerifKey2019Generic SqlBackend)]) deleteWhere ([] :: [Filter VerifKey2019])
-- 43 -- 43
, removeUnique "Message" "UniqueMessage" , removeUnique "Message" "UniqueMessage"
-- 44 -- 44
, removeField "Message" "number" , removeField "Message" "number"
-- 45 -- 45
, removeField "Discussion" "nextMessage" , removeField "Discussion" "nextMessage"
-- 46
, addEntities model_2019_03_19
-- 47
, unchecked $ lift $ do
msgs <- selectList ([] :: [Filter Message2019]) []
let mklocal (Entity mid m) = LocalMessage2019 (message2019Author m) mid
insertMany_ $ map mklocal msgs
-- 48
, removeField "Message" "author"
] ]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

View file

@ -22,7 +22,14 @@ module Vervis.Migration.Model
, model_2016_09_01_rest , model_2016_09_01_rest
, model_2019_02_03_verifkey , model_2019_02_03_verifkey
, VerifKey2019Generic (..) , VerifKey2019Generic (..)
, VerifKey2019
, VerifKeySharedUsage2019Generic (..) , VerifKeySharedUsage2019Generic (..)
, VerifKeySharedUsage2019
, Message2019Generic (..)
, Message2019
, LocalMessage2019Generic (..)
, LocalMessage2019
, model_2019_03_19
) )
where where
@ -66,3 +73,9 @@ model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey")
makeEntitiesMigration "2019" makeEntitiesMigration "2019"
$(modelFile "migrations/2019_02_03_verifkey.model") $(modelFile "migrations/2019_02_03_verifkey.model")
makeEntitiesMigration "2019"
$(modelFile "migrations/2019_03_18_message.model")
model_2019_03_19 :: [Entity SqlBackend]
model_2019_03_19 = $(schema "2019_03_19")

View file

@ -32,18 +32,27 @@ import Yesod.Core.Widget
import qualified Data.Text as T (filter) import qualified Data.Text as T (filter)
import Network.FedURI
import Data.EventTime.Local import Data.EventTime.Local
import Data.Time.Clock.Local () import Data.Time.Clock.Local ()
import Vervis.Discussion (getDiscussionTree) import Vervis.Discussion
import Vervis.Foundation import Vervis.Foundation
import Vervis.MediaType (MediaType (Markdown)) import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident
import Vervis.Render (renderSourceT) import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile) import Vervis.Settings (widgetFile)
import Vervis.Widget.Sharer (personLinkW) import Vervis.Widget.Sharer (personLinkW)
messageW :: UTCTime -> Sharer -> Entity Message -> (MessageId -> Route App) -> Widget actorLinkW :: MessageTreeNodeAuthor -> Widget
messageW now shr (Entity msgid msg) reply = actorLinkW actor = $(widgetFile "widget/actor-link")
where
shortURI (FedURI h p f) = h <> p <> f
messageW
:: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget
messageW now (MessageTreeNode msgid msg author) reply =
let showTime = let showTime =
showEventTime . showEventTime .
intervalToEventTime . intervalToEventTime .
@ -56,12 +65,12 @@ messageTreeW
:: (MessageId -> Route App) :: (MessageId -> Route App)
-> Text -> Text
-> UTCTime -> UTCTime
-> Tree (Entity Message, Sharer) -> Tree MessageTreeNode
-> Widget -> Widget
messageTreeW reply cReplies now t = go t messageTreeW reply cReplies now t = go t
where where
go (Node (message, sharer) trees) = do go (Node mtn trees) = do
messageW now sharer message reply messageW now mtn reply
[whamlet| [whamlet|
<div .#{cReplies}> <div .#{cReplies}>
$forall tree <- trees $forall tree <- trees

View file

@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{messageW now shr (Entity mid msg) replyG} ^{messageW now mtn replyG}
<form method=POST action=@{replyP mid} enctype=#{enctype}> <form method=POST action=@{replyP mid} enctype=#{enctype}>
^{widget} ^{widget}

View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{personLinkW shr} ^{actorLinkW author}
<div> <div>
#{showTime $ messageCreated msg} #{showTime $ messageCreated msg}
<div> <div>

View file

@ -0,0 +1,28 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
$case actor
$of MessageTreeNodeLocal _lmid s
<a href=@{SharerR $ sharerIdent s}>
$maybe name <- sharerName s
#{name}
$nothing
#{shr2text $ sharerIdent s}
<span>
./#{shr2text $ sharerIdent s}
$of MessageTreeNodeRemote uAuthor
<a href="#{renderFedURI uAuthor}">
(?)
<span>
#{shortURI uAuthor}