forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

13
config/models
View file

@ -220,12 +220,23 @@ TicketClaimRequest
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
RemoteMessage
author RemoteSharerId
rest MessageId
UniqueRemoteMessage rest
RepoCollab
repo RepoId
person PersonId

20
migrations/2019_03_18_message.model Normal file
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

11
migrations/2019_03_19.model Normal file
View file

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

65
src/Vervis/Discussion.hs
View file

@ -14,7 +14,9 @@
-}
module Vervis.Discussion
( getDiscussionTree
( MessageTreeNodeAuthor (..)
, MessageTreeNode (..)
, getDiscussionTree
)
where
@ -31,41 +33,66 @@ import Yesod.Persist.Core (runDB)
import qualified Data.HashMap.Lazy as M (fromList, lookup)
import Network.FedURI
import Data.Tree.Local (sortForestOn)
import Vervis.Foundation
import Vervis.Model
getMessages :: AppDB DiscussionId -> Handler [(Entity Message, Sharer)]
getMessages getdid = fmap (map $ second entityVal) $ runDB $ do
did <- getdid
select $ from $ \ (message, person, sharer) -> do
where_ $
message ^. MessageRoot ==. val did &&.
message ^. MessageAuthor ==. person ^. PersonId &&.
person ^. PersonIdent ==. sharer ^. SharerId
return (message, sharer)
data MessageTreeNodeAuthor
= MessageTreeNodeLocal LocalMessageId Sharer
| MessageTreeNodeRemote FedURI
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 =
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
mkEdge n (Entity _ m, _s) =
case messageParent m of
mkEdge n mtn =
case messageParent $ mtnMessage mtn of
Nothing -> Nothing
Just mid ->
case M.lookup mid nodeMap of
Nothing -> error "message parent not in discussion"
Just p -> Just (p, n, ())
edges = mapMaybe (uncurry mkEdge) nodes
graph = mkGraph nodes edges :: Gr (Entity Message, Sharer) ()
roots = [n | (n, (Entity _ m, _s)) <- nodes, isNothing $ messageParent m]
graph = mkGraph nodes edges :: Gr MessageTreeNode ()
roots =
[n | (n, mtn) <- nodes, isNothing $ messageParent $ mtnMessage mtn]
in dffWith lab' roots graph
sortByTime :: Forest (Entity Message, Sharer) -> Forest (Entity Message, Sharer)
sortByTime = sortForestOn $ messageCreated . entityVal . fst
sortByTime :: Forest MessageTreeNode -> Forest MessageTreeNode
sortByTime = sortForestOn $ messageCreated . mtnMessage
-- | Get the tree of messages in a given discussion, with siblings sorted from
-- old to new.
getDiscussionTree :: AppDB DiscussionId -> Handler (Forest (Entity Message, Sharer))
getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode)
getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid

100
src/Vervis/Handler/Discussion.hs
View file

@ -37,6 +37,9 @@ import Yesod.Form.Functions (runFormPost)
import Yesod.Form.Types (FormResult (..))
import Yesod.Persist.Core (runDB, get404, getBy404)
import Network.FedURI
import Vervis.Discussion
import Vervis.Form.Discussion
import Vervis.Foundation (App, Handler, AppDB)
import Vervis.Model
@ -51,21 +54,36 @@ getDiscussion
getDiscussion reply topic getdid =
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
:: (MessageId -> Route App)
-> AppDB DiscussionId
-> MessageId
-> Handler Html
getDiscussionMessage reply getdid mid = do
(msg, shr) <- runDB $ do
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
mtn <- runDB $ getNode getdid mid
now <- liftIO getCurrentTime
defaultLayout $ messageW now shr (Entity mid msg) reply
defaultLayout $ messageW now mtn reply
getTopReply :: Route App -> Handler Html
getTopReply replyP = do
@ -74,7 +92,7 @@ getTopReply replyP = do
postTopReply
:: Route App
-> (MessageId -> Route App)
-> (LocalMessageId -> Route App)
-> AppDB DiscussionId
-> Handler Html
postTopReply replyP after getdid = do
@ -85,14 +103,17 @@ postTopReply replyP after getdid = do
author <- requireAuthId
mnum <- runDB $ do
did <- getdid
let message = Message
{ messageAuthor = author
, messageCreated = now
, messageContent = nmContent nm
, messageParent = Nothing
, messageRoot = did
}
insert message
mid <- insert Message
{ messageCreated = now
, messageContent = nmContent nm
, messageParent = Nothing
, messageRoot = did
}
lmid <- insert LocalMessage
{ localMessageAuthor = author
, localMessageRest = mid
}
return lmid
setMessage "Message submitted."
redirect $ after mnum
FormMissing -> do
@ -109,13 +130,7 @@ getReply
-> MessageId
-> Handler Html
getReply replyG replyP getdid mid = do
(msg, shr) <- runDB $ do
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
mtn <- runDB $ getNode getdid mid
now <- liftIO getCurrentTime
((_result, widget), enctype) <- runFormPost newMessageForm
defaultLayout $(widgetFile "discussion/reply")
@ -123,7 +138,7 @@ getReply replyG replyP getdid mid = do
postReply
:: (MessageId -> Route App)
-> (MessageId -> Route App)
-> (MessageId -> Route App)
-> (LocalMessageId -> Route App)
-> AppDB DiscussionId
-> MessageId
-> Handler Html
@ -139,33 +154,24 @@ postReply replyG replyP after getdid mid = do
message <- get404 mid
unless (messageRoot message == did) notFound
return mid
let message = Message
{ messageAuthor = author
, messageCreated = now
, messageContent = nmContent nm
, messageParent = Just parent
, messageRoot = did
}
insert message
mid <- insert Message
{ messageCreated = now
, messageContent = nmContent nm
, messageParent = Just parent
, messageRoot = did
}
lmid <- insert LocalMessage
{ localMessageAuthor = author
, localMessageRest = mid
}
return lmid
setMessage "Message submitted."
redirect $ after msgid
FormMissing -> do
setMessage "Field(s) missing."
(msg, shr) <- runDB $ do
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
mtn <- runDB $ getNode getdid mid
defaultLayout $(widgetFile "discussion/reply")
FormFailure _l -> do
setMessage "Message submission failed, see errors below."
(msg, shr) <- runDB $ do
did <- getdid
m <- get404 mid
unless (messageRoot m == did) notFound
p <- get404 $ messageAuthor m
s <- get404 $ personIdent p
return (m, s)
mtn <- runDB $ getNode getdid mid
defaultLayout $(widgetFile "discussion/reply")

15
src/Vervis/Migration.hs
View file

@ -38,7 +38,7 @@ import Database.Persist
import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
import Database.Persist.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.Sql (SqlBackend, toSqlKey)
--import Text.Email.QuasiQuotation (email
@ -191,14 +191,23 @@ changes =
, addEntities model_2019_02_03_verifkey
-- 42
, unchecked $ lift $ do
deleteWhere ([] :: [Filter (VerifKeySharedUsage2019Generic SqlBackend)])
deleteWhere ([] :: [Filter (VerifKey2019Generic SqlBackend)])
deleteWhere ([] :: [Filter VerifKeySharedUsage2019])
deleteWhere ([] :: [Filter VerifKey2019])
-- 43
, removeUnique "Message" "UniqueMessage"
-- 44
, removeField "Message" "number"
-- 45
, 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))

13
src/Vervis/Migration/Model.hs
View file

@ -22,7 +22,14 @@ module Vervis.Migration.Model
, model_2016_09_01_rest
, model_2019_02_03_verifkey
, VerifKey2019Generic (..)
, VerifKey2019
, VerifKeySharedUsage2019Generic (..)
, VerifKeySharedUsage2019
, Message2019Generic (..)
, Message2019
, LocalMessage2019Generic (..)
, LocalMessage2019
, model_2019_03_19
)
where
@ -66,3 +73,9 @@ model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey")
makeEntitiesMigration "2019"
$(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")

21
src/Vervis/Widget/Discussion.hs
View file

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

2
templates/discussion/reply.hamlet
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
$# <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}>
^{widget}

4
templates/discussion/widget/message.hamlet
View file

@ -1,6 +1,6 @@
$# 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.
$#
@ -12,7 +12,7 @@ $# 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/>.
^{personLinkW shr}
^{actorLinkW author}
<div>
#{showTime $ messageCreated msg}
<div>

28
templates/widget/actor-link.hamlet Normal file
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}