In ticket discussion, have links to the individual messages (MessageR route)

src/Vervis/Discussion.hs

@@ -27,6 +27,7 @@ import Data.Graph.Inductive.Graph (mkGraph, lab')
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Graph.Inductive.Query.DFS (dffWith)
 import Data.Maybe (isNothing, mapMaybe)
+import Data.Text (Text)
 import Data.Tree (Forest)
 import Database.Esqueleto hiding (isNothing)
 import Yesod.Persist.Core (runDB)
@@ -41,7 +42,7 @@ import Vervis.Model
 
 data MessageTreeNodeAuthor
     = MessageTreeNodeLocal LocalMessageId Sharer
-    | MessageTreeNodeRemote FedURI
+    | MessageTreeNodeRemote Text LocalURI LocalURI
 
 data MessageTreeNode = MessageTreeNode
     { mtnMessageId :: MessageId
@@ -63,13 +64,18 @@ getMessages getdid = runDB $ do
         on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteActorId
         on $ rm ^. RemoteMessageRest ==. m ^. MessageId
         where_ $ m ^. MessageRoot ==. val did
-        return (m, i ^. InstanceHost, rs ^. RemoteActorIdent)
+        return
+            ( m
+            , i ^. InstanceHost
+            , rm ^. RemoteMessageIdent
+            , rs ^. RemoteActorIdent
+            )
     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) =
+    mkremote (Entity mid m, Value h, Value luMsg, Value luAuthor) =
-        MessageTreeNode mid m $ MessageTreeNodeRemote $ l2f h lu
+        MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor
 
 discussionTree :: [MessageTreeNode] -> Forest MessageTreeNode
 discussionTree mss =

src/Vervis/Handler/Discussion.hs

@@ -85,8 +85,11 @@ getNode getdid mid = do
         (Nothing, Just (Entity _rmid rm)) -> do
             rs <- getJust $ remoteMessageAuthor rm
             i <- getJust $ remoteActorInstance rs
-            return $ MessageTreeNodeRemote $
+            return $
-                l2f (instanceHost i) (remoteActorIdent rs)
+                MessageTreeNodeRemote
+                    (instanceHost i)
+                    (remoteMessageIdent rm)
+                    (remoteActorIdent rs)
     return $ MessageTreeNode mid m author
 
 {-

src/Vervis/Widget/Discussion.hs

@@ -33,9 +33,11 @@ import Yesod.Core.Widget
 import qualified Data.Text as T (filter)
 
 import Network.FedURI
+import Yesod.Hashids
 
 import Data.EventTime.Local
 import Data.Time.Clock.Local ()
+
 import Vervis.Discussion
 import Vervis.Foundation
 import Vervis.MediaType (MediaType (Markdown))
@@ -48,18 +50,19 @@ import Vervis.Widget.Sharer (personLinkW)
 actorLinkW :: MessageTreeNodeAuthor -> Widget
 actorLinkW actor = $(widgetFile "widget/actor-link")
     where
-    shortURI (FedURI h p f) = h <> p <> f
+    shortURI h (LocalURI p f) = h <> p <> f
 
 messageW
     :: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget
-messageW now (MessageTreeNode msgid msg author) reply =
+messageW now (MessageTreeNode msgid msg author) reply = do
+    encodeHid <- getEncodeKeyHashid
     let showTime =
             showEventTime .
             intervalToEventTime .
             FriendlyConvert .
             diffUTCTime now
         showContent = renderSourceT Markdown . T.filter (/= '\r')
-    in  $(widgetFile "discussion/widget/message")
+    $(widgetFile "discussion/widget/message")
 
 messageTreeW
     :: (MessageId -> Route App)

templates/discussion/widget/message.hamlet

@@ -14,6 +14,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 ^{actorLinkW author}
 <div>
+  $case author
+    $of MessageTreeNodeLocal lmid s
+      <a href=@{MessageR (sharerIdent s) (encodeHid lmid)}>
+        #{showTime $ messageCreated msg}
+    $of MessageTreeNodeRemote h luMsg _luAuthor
+      <a href="#{renderFedURI $ l2f h luMsg}"}>
         #{showTime $ messageCreated msg}
 <div>
   ^{showContent $ messageContent msg}

templates/widget/actor-link.hamlet

@@ -21,8 +21,8 @@ $case actor
         #{shr2text $ sharerIdent s}
     <span>
       ./s/#{shr2text $ sharerIdent s}
-  $of MessageTreeNodeRemote uAuthor
+  $of MessageTreeNodeRemote h _luMsg luAuthor
-    <a href="#{renderFedURI uAuthor}">
+    <a href="#{renderFedURI $ l2f h luAuthor}">
       (?)
     <span>
-      #{shortURI uAuthor}
+      #{shortURI h luAuthor}