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

config/models

@@ -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

migrations/2019_03_18_message.model

@@ -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

migrations/2019_03_19.model

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

src/Vervis/Discussion.hs

@@ -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

src/Vervis/Handler/Discussion.hs

@@ -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
+                mid <- insert Message
+                    { messageCreated = now
                     , messageContent = nmContent nm
                     , messageParent  = Nothing
                     , messageRoot    = did
                     }
-                insert message
+                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
+                mid <- insert Message
+                    { messageCreated = now
                     , messageContent = nmContent nm
                     , messageParent  = Just parent
                     , messageRoot    = did
                     }
-                insert message
+                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")

src/Vervis/Migration.hs

@@ -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))

src/Vervis/Migration/Model.hs

@@ -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")

src/Vervis/Widget/Discussion.hs

@@ -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

templates/discussion/reply.hamlet

@@ -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}

templates/discussion/widget/message.hamlet

@@ -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>

templates/widget/actor-link.hamlet

@@ -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}