getTicketsR: Deduce ticket URL correctly for HTML output too

src/Vervis/Ticket.hs

@@ -33,6 +33,7 @@ where
 import Control.Arrow ((***))
 import Data.Foldable (for_)
 import Data.Int
+import Data.Maybe (isJust)
 import Data.Text (Text)
 import Data.Traversable
 import Database.Esqueleto
@@ -55,7 +56,7 @@ getTicketSummaries mfilt morder offlim jid = do
         \ ( t
             `InnerJoin` lt
             `InnerJoin` tpl
-            `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
+            `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s `LeftOuterJoin` tup)
             `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
             `InnerJoin` d
             `LeftOuterJoin` m
@@ -66,6 +67,7 @@ getTicketSummaries mfilt morder offlim jid = do
             on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
             on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
             on $ just (tpl ^. TicketProjectLocalId) ==. tar ?. TicketAuthorRemoteTicket
+            on $ tal ?. TicketAuthorLocalId  ==. tup ?. TicketUnderProjectAuthor
             on $ p ?. PersonIdent ==. s ?. SharerId
             on $ tal ?. TicketAuthorLocalAuthor ==. p ?. PersonId
             on $ just (lt ^. LocalTicketId) ==. tal ?. TicketAuthorLocalTicket
@@ -74,7 +76,7 @@ getTicketSummaries mfilt morder offlim jid = do
             where_ $ tpl ^. TicketProjectLocalProject ==. val jid
             groupBy
                 ( t ^. TicketId, lt ^. LocalTicketId
-                , s ?. SharerId
+                , tal ?. TicketAuthorLocalId, s ?. SharerId, tup ?. TicketUnderProjectId
                 , ra ?. RemoteActorId, ro ?. RemoteObjectId, i ?. InstanceId
                 )
             for_ mfilt $ \ filt -> where_ $ filt t
@@ -85,7 +87,9 @@ getTicketSummaries mfilt morder offlim jid = do
             return
                 ( t ^. TicketId
                 , lt ^. LocalTicketId
+                , tal ?. TicketAuthorLocalId
                 , s
+                , tup ?. TicketUnderProjectId
                 , i
                 , ro
                 , ra
@@ -95,7 +99,7 @@ getTicketSummaries mfilt morder offlim jid = do
                 , count $ m ?. MessageId
                 )
     for tickets $
-        \ (Value tid, Value ltid, ms, mi, mro, mra, Value c, Value t, Value d, Value r) -> do
+        \ (Value tid, Value ltid, Value mtalid, ms, Value mtupid, mi, mro, mra, Value c, Value t, Value d, Value r) -> do
             labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do
                 on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId
                 where_ $ tpc ^. TicketParamClassTicket ==. val tid
@@ -103,10 +107,13 @@ getTicketSummaries mfilt morder offlim jid = do
             return TicketSummary
                 { tsId        = ltid
                 , tsCreatedBy =
-                    case (ms, mi, mro, mra) of
+                    case (mtalid, ms, mi, mro, mra) of
-                        (Just s, Nothing, Nothing, Nothing) ->
+                        (Just talid, Just s, Nothing, Nothing, Nothing) ->
-                            Left $ entityVal s
+                            Left
-                        (Nothing, Just i, Just ro, Just ra) ->
+                                ( entityVal s
+                                , if isJust mtupid then Nothing else Just talid
+                                )
+                        (Nothing, Nothing, Just i, Just ro, Just ra) ->
                             Right (entityVal i, entityVal ro, entityVal ra)
                         _ -> error "Ticket author DB invalid state"
                 , tsCreatedAt = c

src/Vervis/Widget/Ticket.hs

@@ -23,6 +23,7 @@ module Vervis.Widget.Ticket
 where
 
 import Control.Arrow ((&&&), (***))
+import Data.Bifunctor
 import Data.HashMap.Lazy (HashMap)
 import Data.Int
 import Data.Maybe (mapMaybe)
@@ -53,7 +54,7 @@ import Vervis.Widget.Sharer
 
 data TicketSummary = TicketSummary
     { tsId        :: LocalTicketId
-    , tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor)
+    , tsCreatedBy :: Either (Sharer, Maybe TicketAuthorLocalId) (Instance, RemoteObject, RemoteActor)
     , tsCreatedAt :: UTCTime
     , tsTitle     :: Text
     , tsLabels    :: [WorkflowField]
@@ -76,14 +77,22 @@ ticketSummaryW
     -> Maybe (HashMap Int64 Int64)
     -> Widget
 ticketSummaryW shr prj ts mcs = do
-    encodeTicketKey <- getEncodeKeyHashid
+    encodeLT <- getEncodeKeyHashid
+    encodeTAL <- getEncodeKeyHashid
     cNew <- newIdent
     cTodo <- newIdent
     cClosed <- newIdent
     let tshow = T.pack . show
         mparams = map (tshow *** tshow) . M.toList <$> mcs
+        ticketRoute = ticketRoute' encodeLT encodeTAL
     mroute <- getCurrentRoute
     $(widgetFile "ticket/widget/summary")
+    where
+    ticketRoute' encodeLT encodeTAL summary =
+        case tsCreatedBy summary of
+            Left (s, Just talid) ->
+                SharerTicketR (sharerIdent s) (encodeTAL talid)
+            _ -> TicketR shr prj $ encodeLT $ tsId summary
 
 -- I'm noticing a pattern. A problem. Some of my widget functions take data and
 -- directly represent it in HTML. Others take some other more general

templates/ticket/widget/summary.hamlet

@@ -25,17 +25,17 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
         ☒
 
 <span .ticket-number-column>
-  <a href=@{TicketR shr prj $ encodeTicketKey $ tsId ts}>
+  <a href=@{ticketRoute ts}>
     ### 
 
 <span .ticket-date-column>
   #{showDate $ tsCreatedAt ts}
 
 <span .ticket-sharer-column>
-  ^{sharerLinkFedW $ tsCreatedBy ts}
+  ^{sharerLinkFedW $ first fst $ tsCreatedBy ts}
 
 <span .ticket-title-column>
-  <a href=@{TicketR shr prj $ encodeTicketKey $ tsId ts}>
+  <a href=@{ticketRoute ts}>
     #{preEscapedToHtml $ tsTitle ts}
   $forall wf <- tsLabels ts
     $maybe wfcol <- workflowFieldColor wf
@@ -52,11 +52,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 $maybe params <- mparams
   <span .ticket-node-column>
-    <a href="#node-#{keyHashidText $ encodeTicketKey $ tsId ts}" title="Jump to subtree">
+    <a href="#node-#{keyHashidText $ encodeLT $ tsId ts}" title="Jump to subtree">
       ☝
     $maybe route <- mroute
       <a href=@?{(route, params)} title="Move subtree here">
         ☚
 $nothing
   <span .ticket-node-column>
-    <a id="node-#{keyHashidText $ encodeTicketKey $ tsId ts}">
+    <a id="node-#{keyHashidText $ encodeLT $ tsId ts}">