UI: Display origin and target repos in getClothR HTML

src/Vervis/Handler/Cloth.hs

@@ -83,7 +83,7 @@ import qualified Database.Esqueleto as E
 
 import Development.PatchMediaType
 import Network.FedURI
-import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..), Repo (..))
+import Web.ActivityPub hiding (Ticket (..), Patch (..), Bundle (..), Repo (..), ActorDetail (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@@ -263,11 +263,12 @@ getClothR loomHash clothHash = do
     where
     getClothHtml = do
         mpid <- maybeAuthId
-        (ticket, author, tparams, eparams, cparams) <- handlerToWidget $ runDB $ do
+        (ticket, targetRepo, author, tparams, eparams, cparams, moriginRepo) <- handlerToWidget $ runDB $ do
-            (_loom, _ticketloom, Entity ticketID ticket, author, _maybe_ResolveAndEitherTrlOrTrr, _bundles) <-
+            (Entity _ loom, Entity _ cloth, Entity ticketID ticket, author, _maybe_ResolveAndEitherTrlOrTrr, proposal) <-
                 getCloth404 loomHash clothHash
-            (ticket,,,,)
+            (ticket,,,,,,)
-                <$> bitraverse
+                <$> getLocalRepo (loomRepo loom) (ticketLoomBranch cloth)
+                <*> bitraverse
                         (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
                             p <- getJust personID
                             (Entity personID p,) <$> getJust (personActor p)
@@ -282,6 +283,16 @@ getClothR loomHash clothHash = do
                 <*> getTicketTextParams ticketID --wid
                 <*> getTicketEnumParams ticketID --wid
                 <*> getTicketClasses ticketID --wid
+                <*> traverse
+                        (bitraverse
+                                (\ (Entity _(MergeOriginLocal _ originRepoID maybeBranch)) ->
+                                    getLocalRepo originRepoID maybeBranch
+                                )
+                                (\ (Entity _ (MergeOriginRemote _ r), mbranch) ->
+                                    getRemoteRepo r mbranch
+                                )
+                        )
+                        (justThere proposal)
         hashMessageKey <- handlerToWidget getEncodeKeyHashid
         let desc :: Widget
             desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
@@ -304,6 +315,25 @@ getClothR loomHash clothHash = do
                     (ClothUnfollowR loomHash clothHash)
                     (ticketFollowers ticket)
         $(widgetFile "cloth/one")
+        where
+        getLocalRepo repoID mbranch = do
+            repo <- getJust repoID
+            actor <- getJust $ repoActor repo
+            repoHash <- encodeKeyHashid repoID
+            return (repoHash, actorName actor, mbranch)
+        getRemoteRepo remoteActorID mbranch = do
+            ra <- getJust remoteActorID
+            ro <- getJust $ remoteActorIdent ra
+            i <- getJust $ remoteObjectInstance ro
+            let h = instanceHost i
+                uRepo = ObjURI h (remoteObjectIdent ro)
+            return
+                ( uRepo
+                , remoteActorName ra
+                , mbranch <&>
+                    \ (Entity _ (MergeOriginRemoteBranch _ mlu b)) ->
+                        (ObjURI h <$> mlu, b)
+                )
 
 getClothDiscussionR
     :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent

templates/cloth/one.hamlet

@@ -19,6 +19,41 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   Created on #{showDate $ ticketCreated ticket} by
   ^{personLinkFedW author}
 
+$maybe originRepo <- moriginRepo
+  <div>
+    Origin:
+    $case originRepo
+      $of Left (repoHash, name, maybeBranch)
+        <a href=@{RepoR repoHash}>
+          ^#{keyHashidText repoHash} #{name}
+        $maybe branch <- maybeBranch
+          :
+          <a href=@{RepoBranchSourceR repoHash branch []}>
+            #{branch}
+      $of Right (uRepo, maybeName, maybeBranch)
+        <a href="${uRepo}">
+          $maybe name <- maybeName
+            #{name}
+          $nothing
+            <i>[unnamed]
+        $maybe (maybeURI, branch) <- maybeBranch
+          :
+          $maybe uri <- maybeURI
+            <a href="${u}">
+              #{branch}
+          $nothing
+            #{branch}
+
+$with (repoHash, name, maybeBranch) <- targetRepo
+  <div>
+    Target:
+    <a href=@{RepoR repoHash}>
+      ^#{keyHashidText repoHash} #{name}
+    $maybe branch <- maybeBranch
+      :
+      <a href=@{RepoBranchSourceR repoHash branch []}>
+        #{branch}
+
 <div>
   <span>
     <a href=@{ClothFollowersR loomHash clothHash}>